This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add test for [perl #130675]
[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         override_recoding;
181 #ifdef EBCDIC
182     I32         recode_x_to_native;
183 #endif
184     I32         in_multi_char_class;
185     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
186                                             within pattern */
187     int         code_index;             /* next code_blocks[] slot */
188     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
189     scan_frame *frame_head;
190     scan_frame *frame_last;
191     U32         frame_count;
192     AV         *warn_text;
193 #ifdef ADD_TO_REGEXEC
194     char        *starttry;              /* -Dr: where regtry was called. */
195 #define RExC_starttry   (pRExC_state->starttry)
196 #endif
197     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
198 #ifdef DEBUGGING
199     const char  *lastparse;
200     I32         lastnum;
201     AV          *paren_name_list;       /* idx -> name */
202     U32         study_chunk_recursed_count;
203     SV          *mysv1;
204     SV          *mysv2;
205 #define RExC_lastparse  (pRExC_state->lastparse)
206 #define RExC_lastnum    (pRExC_state->lastnum)
207 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
208 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
209 #define RExC_mysv       (pRExC_state->mysv1)
210 #define RExC_mysv1      (pRExC_state->mysv1)
211 #define RExC_mysv2      (pRExC_state->mysv2)
212
213 #endif
214     bool        seen_unfolded_sharp_s;
215     bool        strict;
216     bool        study_started;
217 };
218
219 #define RExC_flags      (pRExC_state->flags)
220 #define RExC_pm_flags   (pRExC_state->pm_flags)
221 #define RExC_precomp    (pRExC_state->precomp)
222 #define RExC_precomp_adj (pRExC_state->precomp_adj)
223 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
224 #define RExC_precomp_end (pRExC_state->precomp_end)
225 #define RExC_rx_sv      (pRExC_state->rx_sv)
226 #define RExC_rx         (pRExC_state->rx)
227 #define RExC_rxi        (pRExC_state->rxi)
228 #define RExC_start      (pRExC_state->start)
229 #define RExC_end        (pRExC_state->end)
230 #define RExC_parse      (pRExC_state->parse)
231 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
232
233 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
234  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
235  * something forces the pattern into using /ui rules, the sharp s should be
236  * folded into the sequence 'ss', which takes up more space than previously
237  * calculated.  This means that the sizing pass needs to be restarted.  (The
238  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
239  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
240  * so there is no need to resize [perl #125990]. */
241 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
242
243 #ifdef RE_TRACK_PATTERN_OFFSETS
244 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
245                                                          others */
246 #endif
247 #define RExC_emit       (pRExC_state->emit)
248 #define RExC_emit_dummy (pRExC_state->emit_dummy)
249 #define RExC_emit_start (pRExC_state->emit_start)
250 #define RExC_emit_bound (pRExC_state->emit_bound)
251 #define RExC_sawback    (pRExC_state->sawback)
252 #define RExC_seen       (pRExC_state->seen)
253 #define RExC_size       (pRExC_state->size)
254 #define RExC_maxlen        (pRExC_state->maxlen)
255 #define RExC_npar       (pRExC_state->npar)
256 #define RExC_nestroot   (pRExC_state->nestroot)
257 #define RExC_extralen   (pRExC_state->extralen)
258 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
259 #define RExC_utf8       (pRExC_state->utf8)
260 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
261 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
262 #define RExC_open_parens        (pRExC_state->open_parens)
263 #define RExC_close_parens       (pRExC_state->close_parens)
264 #define RExC_end_op     (pRExC_state->end_op)
265 #define RExC_paren_names        (pRExC_state->paren_names)
266 #define RExC_recurse    (pRExC_state->recurse)
267 #define RExC_recurse_count      (pRExC_state->recurse_count)
268 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
269 #define RExC_study_chunk_recursed_bytes  \
270                                    (pRExC_state->study_chunk_recursed_bytes)
271 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
272 #define RExC_contains_locale    (pRExC_state->contains_locale)
273 #ifdef EBCDIC
274 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
275 #endif
276 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
277 #define RExC_frame_head (pRExC_state->frame_head)
278 #define RExC_frame_last (pRExC_state->frame_last)
279 #define RExC_frame_count (pRExC_state->frame_count)
280 #define RExC_strict (pRExC_state->strict)
281 #define RExC_study_started      (pRExC_state->study_started)
282 #define RExC_warn_text (pRExC_state->warn_text)
283
284 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
285  * a flag to disable back-off on the fixed/floating substrings - if it's
286  * a high complexity pattern we assume the benefit of avoiding a full match
287  * is worth the cost of checking for the substrings even if they rarely help.
288  */
289 #define RExC_naughty    (pRExC_state->naughty)
290 #define TOO_NAUGHTY (10)
291 #define MARK_NAUGHTY(add) \
292     if (RExC_naughty < TOO_NAUGHTY) \
293         RExC_naughty += (add)
294 #define MARK_NAUGHTY_EXP(exp, add) \
295     if (RExC_naughty < TOO_NAUGHTY) \
296         RExC_naughty += RExC_naughty / (exp) + (add)
297
298 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
299 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
300         ((*s) == '{' && regcurly(s)))
301
302 /*
303  * Flags to be passed up and down.
304  */
305 #define WORST           0       /* Worst case. */
306 #define HASWIDTH        0x01    /* Known to match non-null strings. */
307
308 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
309  * character.  (There needs to be a case: in the switch statement in regexec.c
310  * for any node marked SIMPLE.)  Note that this is not the same thing as
311  * REGNODE_SIMPLE */
312 #define SIMPLE          0x02
313 #define SPSTART         0x04    /* Starts with * or + */
314 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
315 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
316 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
317 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
318                                    calcuate sizes as UTF-8 */
319
320 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
321
322 /* whether trie related optimizations are enabled */
323 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
324 #define TRIE_STUDY_OPT
325 #define FULL_TRIE_STUDY
326 #define TRIE_STCLASS
327 #endif
328
329
330
331 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
332 #define PBITVAL(paren) (1 << ((paren) & 7))
333 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
334 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
335 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
336
337 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
338                                      if (!UTF) {                           \
339                                          assert(PASS1);                    \
340                                          *flagp = RESTART_PASS1|NEED_UTF8; \
341                                          return NULL;                      \
342                                      }                                     \
343                              } STMT_END
344
345 /* Change from /d into /u rules, and restart the parse if we've already seen
346  * something whose size would increase as a result, by setting *flagp and
347  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
348  * we've change to /u during the parse.  */
349 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
350     STMT_START {                                                            \
351             if (DEPENDS_SEMANTICS) {                                        \
352                 assert(PASS1);                                              \
353                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
354                 RExC_uni_semantics = 1;                                     \
355                 if (RExC_seen_unfolded_sharp_s) {                           \
356                     *flagp |= RESTART_PASS1;                                \
357                     return restart_retval;                                  \
358                 }                                                           \
359             }                                                               \
360     } STMT_END
361
362 /* This converts the named class defined in regcomp.h to its equivalent class
363  * number defined in handy.h. */
364 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
365 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
366
367 #define _invlist_union_complement_2nd(a, b, output) \
368                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
369 #define _invlist_intersection_complement_2nd(a, b, output) \
370                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
371
372 /* About scan_data_t.
373
374   During optimisation we recurse through the regexp program performing
375   various inplace (keyhole style) optimisations. In addition study_chunk
376   and scan_commit populate this data structure with information about
377   what strings MUST appear in the pattern. We look for the longest
378   string that must appear at a fixed location, and we look for the
379   longest string that may appear at a floating location. So for instance
380   in the pattern:
381
382     /FOO[xX]A.*B[xX]BAR/
383
384   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
385   strings (because they follow a .* construct). study_chunk will identify
386   both FOO and BAR as being the longest fixed and floating strings respectively.
387
388   The strings can be composites, for instance
389
390      /(f)(o)(o)/
391
392   will result in a composite fixed substring 'foo'.
393
394   For each string some basic information is maintained:
395
396   - offset or min_offset
397     This is the position the string must appear at, or not before.
398     It also implicitly (when combined with minlenp) tells us how many
399     characters must match before the string we are searching for.
400     Likewise when combined with minlenp and the length of the string it
401     tells us how many characters must appear after the string we have
402     found.
403
404   - max_offset
405     Only used for floating strings. This is the rightmost point that
406     the string can appear at. If set to SSize_t_MAX it indicates that the
407     string can occur infinitely far to the right.
408
409   - minlenp
410     A pointer to the minimum number of characters of the pattern that the
411     string was found inside. This is important as in the case of positive
412     lookahead or positive lookbehind we can have multiple patterns
413     involved. Consider
414
415     /(?=FOO).*F/
416
417     The minimum length of the pattern overall is 3, the minimum length
418     of the lookahead part is 3, but the minimum length of the part that
419     will actually match is 1. So 'FOO's minimum length is 3, but the
420     minimum length for the F is 1. This is important as the minimum length
421     is used to determine offsets in front of and behind the string being
422     looked for.  Since strings can be composites this is the length of the
423     pattern at the time it was committed with a scan_commit. Note that
424     the length is calculated by study_chunk, so that the minimum lengths
425     are not known until the full pattern has been compiled, thus the
426     pointer to the value.
427
428   - lookbehind
429
430     In the case of lookbehind the string being searched for can be
431     offset past the start point of the final matching string.
432     If this value was just blithely removed from the min_offset it would
433     invalidate some of the calculations for how many chars must match
434     before or after (as they are derived from min_offset and minlen and
435     the length of the string being searched for).
436     When the final pattern is compiled and the data is moved from the
437     scan_data_t structure into the regexp structure the information
438     about lookbehind is factored in, with the information that would
439     have been lost precalculated in the end_shift field for the
440     associated string.
441
442   The fields pos_min and pos_delta are used to store the minimum offset
443   and the delta to the maximum offset at the current point in the pattern.
444
445 */
446
447 typedef struct scan_data_t {
448     /*I32 len_min;      unused */
449     /*I32 len_delta;    unused */
450     SSize_t pos_min;
451     SSize_t pos_delta;
452     SV *last_found;
453     SSize_t last_end;       /* min value, <0 unless valid. */
454     SSize_t last_start_min;
455     SSize_t last_start_max;
456     SV **longest;           /* Either &l_fixed, or &l_float. */
457     SV *longest_fixed;      /* longest fixed string found in pattern */
458     SSize_t offset_fixed;   /* offset where it starts */
459     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
460     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
461     SV *longest_float;      /* longest floating string found in pattern */
462     SSize_t offset_float_min; /* earliest point in string it can appear */
463     SSize_t offset_float_max; /* latest point in string it can appear */
464     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
465     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
466     I32 flags;
467     I32 whilem_c;
468     SSize_t *last_closep;
469     regnode_ssc *start_class;
470 } scan_data_t;
471
472 /*
473  * Forward declarations for pregcomp()'s friends.
474  */
475
476 static const scan_data_t zero_scan_data =
477   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
478
479 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
480 #define SF_BEFORE_SEOL          0x0001
481 #define SF_BEFORE_MEOL          0x0002
482 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
483 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
484
485 #define SF_FIX_SHIFT_EOL        (+2)
486 #define SF_FL_SHIFT_EOL         (+4)
487
488 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
489 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
490
491 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
492 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
493 #define SF_IS_INF               0x0040
494 #define SF_HAS_PAR              0x0080
495 #define SF_IN_PAR               0x0100
496 #define SF_HAS_EVAL             0x0200
497
498
499 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
500  * longest substring in the pattern. When it is not set the optimiser keeps
501  * track of position, but does not keep track of the actual strings seen,
502  *
503  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
504  * /foo/i will not.
505  *
506  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
507  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
508  * turned off because of the alternation (BRANCH). */
509 #define SCF_DO_SUBSTR           0x0400
510
511 #define SCF_DO_STCLASS_AND      0x0800
512 #define SCF_DO_STCLASS_OR       0x1000
513 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
514 #define SCF_WHILEM_VISITED_POS  0x2000
515
516 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
517 #define SCF_SEEN_ACCEPT         0x8000
518 #define SCF_TRIE_DOING_RESTUDY 0x10000
519 #define SCF_IN_DEFINE          0x20000
520
521
522
523
524 #define UTF cBOOL(RExC_utf8)
525
526 /* The enums for all these are ordered so things work out correctly */
527 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
528 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
529                                                      == REGEX_DEPENDS_CHARSET)
530 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
531 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
532                                                      >= REGEX_UNICODE_CHARSET)
533 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
534                                             == REGEX_ASCII_RESTRICTED_CHARSET)
535 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
536                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
537 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
538                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
539
540 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
541
542 /* For programs that want to be strictly Unicode compatible by dying if any
543  * attempt is made to match a non-Unicode code point against a Unicode
544  * property.  */
545 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
546
547 #define OOB_NAMEDCLASS          -1
548
549 /* There is no code point that is out-of-bounds, so this is problematic.  But
550  * its only current use is to initialize a variable that is always set before
551  * looked at. */
552 #define OOB_UNICODE             0xDEADBEEF
553
554 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
555
556
557 /* length of regex to show in messages that don't mark a position within */
558 #define RegexLengthToShowInErrorMessages 127
559
560 /*
561  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
562  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
563  * op/pragma/warn/regcomp.
564  */
565 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
566 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
567
568 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
569                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
570
571 /* The code in this file in places uses one level of recursion with parsing
572  * rebased to an alternate string constructed by us in memory.  This can take
573  * the form of something that is completely different from the input, or
574  * something that uses the input as part of the alternate.  In the first case,
575  * there should be no possibility of an error, as we are in complete control of
576  * the alternate string.  But in the second case we don't control the input
577  * portion, so there may be errors in that.  Here's an example:
578  *      /[abc\x{DF}def]/ui
579  * is handled specially because \x{df} folds to a sequence of more than one
580  * character, 'ss'.  What is done is to create and parse an alternate string,
581  * which looks like this:
582  *      /(?:\x{DF}|[abc\x{DF}def])/ui
583  * where it uses the input unchanged in the middle of something it constructs,
584  * which is a branch for the DF outside the character class, and clustering
585  * parens around the whole thing. (It knows enough to skip the DF inside the
586  * class while in this substitute parse.) 'abc' and 'def' may have errors that
587  * need to be reported.  The general situation looks like this:
588  *
589  *              sI                       tI               xI       eI
590  * Input:       ----------------------------------------------------
591  * Constructed:         ---------------------------------------------------
592  *                      sC               tC               xC       eC     EC
593  *
594  * The input string sI..eI is the input pattern.  The string sC..EC is the
595  * constructed substitute parse string.  The portions sC..tC and eC..EC are
596  * constructed by us.  The portion tC..eC is an exact duplicate of the input
597  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
598  * while parsing, we find an error at xC.  We want to display a message showing
599  * the real input string.  Thus we need to find the point xI in it which
600  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
601  * been constructed by us, and so shouldn't have errors.  We get:
602  *
603  *      xI = sI + (tI - sI) + (xC - tC)
604  *
605  * and, the offset into sI is:
606  *
607  *      (xI - sI) = (tI - sI) + (xC - tC)
608  *
609  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
610  * and we save tC as RExC_adjusted_start.
611  *
612  * During normal processing of the input pattern, everything points to that,
613  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
614  */
615
616 #define tI_sI           RExC_precomp_adj
617 #define tC              RExC_adjusted_start
618 #define sC              RExC_precomp
619 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
620 #define xI(xC)          (sC + xI_offset(xC))
621 #define eC              RExC_precomp_end
622
623 #define REPORT_LOCATION_ARGS(xC)                                            \
624     UTF8fARG(UTF,                                                           \
625              (xI(xC) > eC) /* Don't run off end */                          \
626               ? eC - sC   /* Length before the <--HERE */                   \
627               : xI_offset(xC),                                              \
628              sC),         /* The input pattern printed up to the <--HERE */ \
629     UTF8fARG(UTF,                                                           \
630              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
631              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
632
633 /* Used to point after bad bytes for an error message, but avoid skipping
634  * past a nul byte. */
635 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
636
637 /*
638  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
639  * arg. Show regex, up to a maximum length. If it's too long, chop and add
640  * "...".
641  */
642 #define _FAIL(code) STMT_START {                                        \
643     const char *ellipses = "";                                          \
644     IV len = RExC_precomp_end - RExC_precomp;                                   \
645                                                                         \
646     if (!SIZE_ONLY)                                                     \
647         SAVEFREESV(RExC_rx_sv);                                         \
648     if (len > RegexLengthToShowInErrorMessages) {                       \
649         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
650         len = RegexLengthToShowInErrorMessages - 10;                    \
651         ellipses = "...";                                               \
652     }                                                                   \
653     code;                                                               \
654 } STMT_END
655
656 #define FAIL(msg) _FAIL(                            \
657     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
658             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
659
660 #define FAIL2(msg,arg) _FAIL(                       \
661     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
662             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
663
664 /*
665  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
666  */
667 #define Simple_vFAIL(m) STMT_START {                                    \
668     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
669             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
670 } STMT_END
671
672 /*
673  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
674  */
675 #define vFAIL(m) STMT_START {                           \
676     if (!SIZE_ONLY)                                     \
677         SAVEFREESV(RExC_rx_sv);                         \
678     Simple_vFAIL(m);                                    \
679 } STMT_END
680
681 /*
682  * Like Simple_vFAIL(), but accepts two arguments.
683  */
684 #define Simple_vFAIL2(m,a1) STMT_START {                        \
685     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
686                       REPORT_LOCATION_ARGS(RExC_parse));        \
687 } STMT_END
688
689 /*
690  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
691  */
692 #define vFAIL2(m,a1) STMT_START {                       \
693     if (!SIZE_ONLY)                                     \
694         SAVEFREESV(RExC_rx_sv);                         \
695     Simple_vFAIL2(m, a1);                               \
696 } STMT_END
697
698
699 /*
700  * Like Simple_vFAIL(), but accepts three arguments.
701  */
702 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
703     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
704             REPORT_LOCATION_ARGS(RExC_parse));                  \
705 } STMT_END
706
707 /*
708  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
709  */
710 #define vFAIL3(m,a1,a2) STMT_START {                    \
711     if (!SIZE_ONLY)                                     \
712         SAVEFREESV(RExC_rx_sv);                         \
713     Simple_vFAIL3(m, a1, a2);                           \
714 } STMT_END
715
716 /*
717  * Like Simple_vFAIL(), but accepts four arguments.
718  */
719 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
720     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
721             REPORT_LOCATION_ARGS(RExC_parse));                  \
722 } STMT_END
723
724 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
725     if (!SIZE_ONLY)                                     \
726         SAVEFREESV(RExC_rx_sv);                         \
727     Simple_vFAIL4(m, a1, a2, a3);                       \
728 } STMT_END
729
730 /* A specialized version of vFAIL2 that works with UTF8f */
731 #define vFAIL2utf8f(m, a1) STMT_START {             \
732     if (!SIZE_ONLY)                                 \
733         SAVEFREESV(RExC_rx_sv);                     \
734     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
735             REPORT_LOCATION_ARGS(RExC_parse));      \
736 } STMT_END
737
738 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
739     if (!SIZE_ONLY)                                     \
740         SAVEFREESV(RExC_rx_sv);                         \
741     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
742             REPORT_LOCATION_ARGS(RExC_parse));          \
743 } STMT_END
744
745 /* These have asserts in them because of [perl #122671] Many warnings in
746  * regcomp.c can occur twice.  If they get output in pass1 and later in that
747  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
748  * would get output again.  So they should be output in pass2, and these
749  * asserts make sure new warnings follow that paradigm. */
750
751 /* m is not necessarily a "literal string", in this macro */
752 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
753     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
754                                        "%s" REPORT_LOCATION,            \
755                                   m, REPORT_LOCATION_ARGS(loc));        \
756 } STMT_END
757
758 #define ckWARNreg(loc,m) STMT_START {                                   \
759     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
760                                           m REPORT_LOCATION,            \
761                                           REPORT_LOCATION_ARGS(loc));   \
762 } STMT_END
763
764 #define vWARN(loc, m) STMT_START {                                      \
765     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
766                                        m REPORT_LOCATION,               \
767                                        REPORT_LOCATION_ARGS(loc));      \
768 } STMT_END
769
770 #define vWARN_dep(loc, m) STMT_START {                                  \
771     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
772                                        m REPORT_LOCATION,               \
773                                        REPORT_LOCATION_ARGS(loc));      \
774 } STMT_END
775
776 #define ckWARNdep(loc,m) STMT_START {                                   \
777     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
778                                             m REPORT_LOCATION,          \
779                                             REPORT_LOCATION_ARGS(loc)); \
780 } STMT_END
781
782 #define ckWARNregdep(loc,m) STMT_START {                                    \
783     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
784                                                       WARN_REGEXP),         \
785                                              m REPORT_LOCATION,             \
786                                              REPORT_LOCATION_ARGS(loc));    \
787 } STMT_END
788
789 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
790     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
791                                             m REPORT_LOCATION,              \
792                                             a1, REPORT_LOCATION_ARGS(loc)); \
793 } STMT_END
794
795 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
796     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
797                                           m REPORT_LOCATION,                \
798                                           a1, REPORT_LOCATION_ARGS(loc));   \
799 } STMT_END
800
801 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
802     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
803                                        m REPORT_LOCATION,                   \
804                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
805 } STMT_END
806
807 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
808     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
809                                           m REPORT_LOCATION,                \
810                                           a1, a2,                           \
811                                           REPORT_LOCATION_ARGS(loc));       \
812 } STMT_END
813
814 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
815     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
816                                        m REPORT_LOCATION,               \
817                                        a1, a2, a3,                      \
818                                        REPORT_LOCATION_ARGS(loc));      \
819 } STMT_END
820
821 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
822     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
823                                           m REPORT_LOCATION,            \
824                                           a1, a2, a3,                   \
825                                           REPORT_LOCATION_ARGS(loc));   \
826 } STMT_END
827
828 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
829     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
830                                        m REPORT_LOCATION,               \
831                                        a1, a2, a3, a4,                  \
832                                        REPORT_LOCATION_ARGS(loc));      \
833 } STMT_END
834
835 /* Macros for recording node offsets.   20001227 mjd@plover.com
836  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
837  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
838  * Element 0 holds the number n.
839  * Position is 1 indexed.
840  */
841 #ifndef RE_TRACK_PATTERN_OFFSETS
842 #define Set_Node_Offset_To_R(node,byte)
843 #define Set_Node_Offset(node,byte)
844 #define Set_Cur_Node_Offset
845 #define Set_Node_Length_To_R(node,len)
846 #define Set_Node_Length(node,len)
847 #define Set_Node_Cur_Length(node,start)
848 #define Node_Offset(n)
849 #define Node_Length(n)
850 #define Set_Node_Offset_Length(node,offset,len)
851 #define ProgLen(ri) ri->u.proglen
852 #define SetProgLen(ri,x) ri->u.proglen = x
853 #else
854 #define ProgLen(ri) ri->u.offsets[0]
855 #define SetProgLen(ri,x) ri->u.offsets[0] = x
856 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
857     if (! SIZE_ONLY) {                                                  \
858         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
859                     __LINE__, (int)(node), (int)(byte)));               \
860         if((node) < 0) {                                                \
861             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
862                                          (int)(node));                  \
863         } else {                                                        \
864             RExC_offsets[2*(node)-1] = (byte);                          \
865         }                                                               \
866     }                                                                   \
867 } STMT_END
868
869 #define Set_Node_Offset(node,byte) \
870     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
871 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
872
873 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
874     if (! SIZE_ONLY) {                                                  \
875         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
876                 __LINE__, (int)(node), (int)(len)));                    \
877         if((node) < 0) {                                                \
878             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
879                                          (int)(node));                  \
880         } else {                                                        \
881             RExC_offsets[2*(node)] = (len);                             \
882         }                                                               \
883     }                                                                   \
884 } STMT_END
885
886 #define Set_Node_Length(node,len) \
887     Set_Node_Length_To_R((node)-RExC_emit_start, len)
888 #define Set_Node_Cur_Length(node, start)                \
889     Set_Node_Length(node, RExC_parse - start)
890
891 /* Get offsets and lengths */
892 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
893 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
894
895 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
896     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
897     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
898 } STMT_END
899 #endif
900
901 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
902 #define EXPERIMENTAL_INPLACESCAN
903 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
904
905 #ifdef DEBUGGING
906 int
907 Perl_re_printf(pTHX_ const char *fmt, ...)
908 {
909     va_list ap;
910     int result;
911     PerlIO *f= Perl_debug_log;
912     PERL_ARGS_ASSERT_RE_PRINTF;
913     va_start(ap, fmt);
914     result = PerlIO_vprintf(f, fmt, ap);
915     va_end(ap);
916     return result;
917 }
918
919 int
920 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
921 {
922     va_list ap;
923     int result;
924     PerlIO *f= Perl_debug_log;
925     PERL_ARGS_ASSERT_RE_INDENTF;
926     va_start(ap, depth);
927     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
928     result = PerlIO_vprintf(f, fmt, ap);
929     va_end(ap);
930     return result;
931 }
932 #endif /* DEBUGGING */
933
934 #define DEBUG_RExC_seen()                                                   \
935         DEBUG_OPTIMISE_MORE_r({                                             \
936             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
937                                                                             \
938             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
939                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
940                                                                             \
941             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
942                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
943                                                                             \
944             if (RExC_seen & REG_GPOS_SEEN)                                  \
945                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
946                                                                             \
947             if (RExC_seen & REG_RECURSE_SEEN)                               \
948                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
949                                                                             \
950             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
951                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
952                                                                             \
953             if (RExC_seen & REG_VERBARG_SEEN)                               \
954                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
955                                                                             \
956             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
957                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
958                                                                             \
959             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
960                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
961                                                                             \
962             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
963                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
964                                                                             \
965             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
966                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
967                                                                             \
968             Perl_re_printf( aTHX_ "\n");                                                \
969         });
970
971 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
972   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
973
974 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
975     if ( ( flags ) ) {                                                      \
976         Perl_re_printf( aTHX_  "%s", open_str);                                         \
977         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
978         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
979         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
980         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
981         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
982         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
983         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
984         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
985         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
986         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
987         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
988         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
989         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
990         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
991         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
992         Perl_re_printf( aTHX_  "%s", close_str);                                        \
993     }
994
995
996 #define DEBUG_STUDYDATA(str,data,depth)                              \
997 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
998     Perl_re_indentf( aTHX_  "" str "Pos:%" IVdf "/%" IVdf            \
999         " Flags: 0x%" UVXf,                                          \
1000         depth,                                                       \
1001         (IV)((data)->pos_min),                                       \
1002         (IV)((data)->pos_delta),                                     \
1003         (UV)((data)->flags)                                          \
1004     );                                                               \
1005     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
1006     Perl_re_printf( aTHX_                                            \
1007         " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",                    \
1008         (IV)((data)->whilem_c),                                      \
1009         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
1010         is_inf ? "INF " : ""                                         \
1011     );                                                               \
1012     if ((data)->last_found)                                          \
1013         Perl_re_printf( aTHX_                                        \
1014             "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf                   \
1015             " %sFixed:'%s' @ %" IVdf                                 \
1016             " %sFloat: '%s' @ %" IVdf "/%" IVdf,                     \
1017             SvPVX_const((data)->last_found),                         \
1018             (IV)((data)->last_end),                                  \
1019             (IV)((data)->last_start_min),                            \
1020             (IV)((data)->last_start_max),                            \
1021             ((data)->longest &&                                      \
1022              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
1023             SvPVX_const((data)->longest_fixed),                      \
1024             (IV)((data)->offset_fixed),                              \
1025             ((data)->longest &&                                      \
1026              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
1027             SvPVX_const((data)->longest_float),                      \
1028             (IV)((data)->offset_float_min),                          \
1029             (IV)((data)->offset_float_max)                           \
1030         );                                                           \
1031     Perl_re_printf( aTHX_ "\n");                                                 \
1032 });
1033
1034
1035 /* =========================================================
1036  * BEGIN edit_distance stuff.
1037  *
1038  * This calculates how many single character changes of any type are needed to
1039  * transform a string into another one.  It is taken from version 3.1 of
1040  *
1041  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1042  */
1043
1044 /* Our unsorted dictionary linked list.   */
1045 /* Note we use UVs, not chars. */
1046
1047 struct dictionary{
1048   UV key;
1049   UV value;
1050   struct dictionary* next;
1051 };
1052 typedef struct dictionary item;
1053
1054
1055 PERL_STATIC_INLINE item*
1056 push(UV key,item* curr)
1057 {
1058     item* head;
1059     Newxz(head, 1, item);
1060     head->key = key;
1061     head->value = 0;
1062     head->next = curr;
1063     return head;
1064 }
1065
1066
1067 PERL_STATIC_INLINE item*
1068 find(item* head, UV key)
1069 {
1070     item* iterator = head;
1071     while (iterator){
1072         if (iterator->key == key){
1073             return iterator;
1074         }
1075         iterator = iterator->next;
1076     }
1077
1078     return NULL;
1079 }
1080
1081 PERL_STATIC_INLINE item*
1082 uniquePush(item* head,UV key)
1083 {
1084     item* iterator = head;
1085
1086     while (iterator){
1087         if (iterator->key == key) {
1088             return head;
1089         }
1090         iterator = iterator->next;
1091     }
1092
1093     return push(key,head);
1094 }
1095
1096 PERL_STATIC_INLINE void
1097 dict_free(item* head)
1098 {
1099     item* iterator = head;
1100
1101     while (iterator) {
1102         item* temp = iterator;
1103         iterator = iterator->next;
1104         Safefree(temp);
1105     }
1106
1107     head = NULL;
1108 }
1109
1110 /* End of Dictionary Stuff */
1111
1112 /* All calculations/work are done here */
1113 STATIC int
1114 S_edit_distance(const UV* src,
1115                 const UV* tgt,
1116                 const STRLEN x,             /* length of src[] */
1117                 const STRLEN y,             /* length of tgt[] */
1118                 const SSize_t maxDistance
1119 )
1120 {
1121     item *head = NULL;
1122     UV swapCount,swapScore,targetCharCount,i,j;
1123     UV *scores;
1124     UV score_ceil = x + y;
1125
1126     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1127
1128     /* intialize matrix start values */
1129     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1130     scores[0] = score_ceil;
1131     scores[1 * (y + 2) + 0] = score_ceil;
1132     scores[0 * (y + 2) + 1] = score_ceil;
1133     scores[1 * (y + 2) + 1] = 0;
1134     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1135
1136     /* work loops    */
1137     /* i = src index */
1138     /* j = tgt index */
1139     for (i=1;i<=x;i++) {
1140         if (i < x)
1141             head = uniquePush(head,src[i]);
1142         scores[(i+1) * (y + 2) + 1] = i;
1143         scores[(i+1) * (y + 2) + 0] = score_ceil;
1144         swapCount = 0;
1145
1146         for (j=1;j<=y;j++) {
1147             if (i == 1) {
1148                 if(j < y)
1149                 head = uniquePush(head,tgt[j]);
1150                 scores[1 * (y + 2) + (j + 1)] = j;
1151                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1152             }
1153
1154             targetCharCount = find(head,tgt[j-1])->value;
1155             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1156
1157             if (src[i-1] != tgt[j-1]){
1158                 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));
1159             }
1160             else {
1161                 swapCount = j;
1162                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1163             }
1164         }
1165
1166         find(head,src[i-1])->value = i;
1167     }
1168
1169     {
1170         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1171         dict_free(head);
1172         Safefree(scores);
1173         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1174     }
1175 }
1176
1177 /* END of edit_distance() stuff
1178  * ========================================================= */
1179
1180 /* is c a control character for which we have a mnemonic? */
1181 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1182
1183 STATIC const char *
1184 S_cntrl_to_mnemonic(const U8 c)
1185 {
1186     /* Returns the mnemonic string that represents character 'c', if one
1187      * exists; NULL otherwise.  The only ones that exist for the purposes of
1188      * this routine are a few control characters */
1189
1190     switch (c) {
1191         case '\a':       return "\\a";
1192         case '\b':       return "\\b";
1193         case ESC_NATIVE: return "\\e";
1194         case '\f':       return "\\f";
1195         case '\n':       return "\\n";
1196         case '\r':       return "\\r";
1197         case '\t':       return "\\t";
1198     }
1199
1200     return NULL;
1201 }
1202
1203 /* Mark that we cannot extend a found fixed substring at this point.
1204    Update the longest found anchored substring and the longest found
1205    floating substrings if needed. */
1206
1207 STATIC void
1208 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1209                     SSize_t *minlenp, int is_inf)
1210 {
1211     const STRLEN l = CHR_SVLEN(data->last_found);
1212     const STRLEN old_l = CHR_SVLEN(*data->longest);
1213     GET_RE_DEBUG_FLAGS_DECL;
1214
1215     PERL_ARGS_ASSERT_SCAN_COMMIT;
1216
1217     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1218         SvSetMagicSV(*data->longest, data->last_found);
1219         if (*data->longest == data->longest_fixed) {
1220             data->offset_fixed = l ? data->last_start_min : data->pos_min;
1221             if (data->flags & SF_BEFORE_EOL)
1222                 data->flags
1223                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
1224             else
1225                 data->flags &= ~SF_FIX_BEFORE_EOL;
1226             data->minlen_fixed=minlenp;
1227             data->lookbehind_fixed=0;
1228         }
1229         else { /* *data->longest == data->longest_float */
1230             data->offset_float_min = l ? data->last_start_min : data->pos_min;
1231             data->offset_float_max = (l
1232                           ? data->last_start_max
1233                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1234                                          ? SSize_t_MAX
1235                                          : data->pos_min + data->pos_delta));
1236             if (is_inf
1237                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
1238                 data->offset_float_max = SSize_t_MAX;
1239             if (data->flags & SF_BEFORE_EOL)
1240                 data->flags
1241                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
1242             else
1243                 data->flags &= ~SF_FL_BEFORE_EOL;
1244             data->minlen_float=minlenp;
1245             data->lookbehind_float=0;
1246         }
1247     }
1248     SvCUR_set(data->last_found, 0);
1249     {
1250         SV * const sv = data->last_found;
1251         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1252             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1253             if (mg)
1254                 mg->mg_len = 0;
1255         }
1256     }
1257     data->last_end = -1;
1258     data->flags &= ~SF_BEFORE_EOL;
1259     DEBUG_STUDYDATA("commit: ",data,0);
1260 }
1261
1262 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1263  * list that describes which code points it matches */
1264
1265 STATIC void
1266 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1267 {
1268     /* Set the SSC 'ssc' to match an empty string or any code point */
1269
1270     PERL_ARGS_ASSERT_SSC_ANYTHING;
1271
1272     assert(is_ANYOF_SYNTHETIC(ssc));
1273
1274     /* mortalize so won't leak */
1275     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1276     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1277 }
1278
1279 STATIC int
1280 S_ssc_is_anything(const regnode_ssc *ssc)
1281 {
1282     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1283      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1284      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1285      * in any way, so there's no point in using it */
1286
1287     UV start, end;
1288     bool ret;
1289
1290     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1291
1292     assert(is_ANYOF_SYNTHETIC(ssc));
1293
1294     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1295         return FALSE;
1296     }
1297
1298     /* See if the list consists solely of the range 0 - Infinity */
1299     invlist_iterinit(ssc->invlist);
1300     ret = invlist_iternext(ssc->invlist, &start, &end)
1301           && start == 0
1302           && end == UV_MAX;
1303
1304     invlist_iterfinish(ssc->invlist);
1305
1306     if (ret) {
1307         return TRUE;
1308     }
1309
1310     /* If e.g., both \w and \W are set, matches everything */
1311     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1312         int i;
1313         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1314             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1315                 return TRUE;
1316             }
1317         }
1318     }
1319
1320     return FALSE;
1321 }
1322
1323 STATIC void
1324 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1325 {
1326     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1327      * string, any code point, or any posix class under locale */
1328
1329     PERL_ARGS_ASSERT_SSC_INIT;
1330
1331     Zero(ssc, 1, regnode_ssc);
1332     set_ANYOF_SYNTHETIC(ssc);
1333     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1334     ssc_anything(ssc);
1335
1336     /* If any portion of the regex is to operate under locale rules that aren't
1337      * fully known at compile time, initialization includes it.  The reason
1338      * this isn't done for all regexes is that the optimizer was written under
1339      * the assumption that locale was all-or-nothing.  Given the complexity and
1340      * lack of documentation in the optimizer, and that there are inadequate
1341      * test cases for locale, many parts of it may not work properly, it is
1342      * safest to avoid locale unless necessary. */
1343     if (RExC_contains_locale) {
1344         ANYOF_POSIXL_SETALL(ssc);
1345     }
1346     else {
1347         ANYOF_POSIXL_ZERO(ssc);
1348     }
1349 }
1350
1351 STATIC int
1352 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1353                         const regnode_ssc *ssc)
1354 {
1355     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1356      * to the list of code points matched, and locale posix classes; hence does
1357      * not check its flags) */
1358
1359     UV start, end;
1360     bool ret;
1361
1362     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1363
1364     assert(is_ANYOF_SYNTHETIC(ssc));
1365
1366     invlist_iterinit(ssc->invlist);
1367     ret = invlist_iternext(ssc->invlist, &start, &end)
1368           && start == 0
1369           && end == UV_MAX;
1370
1371     invlist_iterfinish(ssc->invlist);
1372
1373     if (! ret) {
1374         return FALSE;
1375     }
1376
1377     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1378         return FALSE;
1379     }
1380
1381     return TRUE;
1382 }
1383
1384 STATIC SV*
1385 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1386                                const regnode_charclass* const node)
1387 {
1388     /* Returns a mortal inversion list defining which code points are matched
1389      * by 'node', which is of type ANYOF.  Handles complementing the result if
1390      * appropriate.  If some code points aren't knowable at this time, the
1391      * returned list must, and will, contain every code point that is a
1392      * possibility. */
1393
1394     SV* invlist = NULL;
1395     SV* only_utf8_locale_invlist = NULL;
1396     unsigned int i;
1397     const U32 n = ARG(node);
1398     bool new_node_has_latin1 = FALSE;
1399
1400     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1401
1402     /* Look at the data structure created by S_set_ANYOF_arg() */
1403     if (n != ANYOF_ONLY_HAS_BITMAP) {
1404         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1405         AV * const av = MUTABLE_AV(SvRV(rv));
1406         SV **const ary = AvARRAY(av);
1407         assert(RExC_rxi->data->what[n] == 's');
1408
1409         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1410             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1411         }
1412         else if (ary[0] && ary[0] != &PL_sv_undef) {
1413
1414             /* Here, no compile-time swash, and there are things that won't be
1415              * known until runtime -- we have to assume it could be anything */
1416             invlist = sv_2mortal(_new_invlist(1));
1417             return _add_range_to_invlist(invlist, 0, UV_MAX);
1418         }
1419         else if (ary[3] && ary[3] != &PL_sv_undef) {
1420
1421             /* Here no compile-time swash, and no run-time only data.  Use the
1422              * node's inversion list */
1423             invlist = sv_2mortal(invlist_clone(ary[3]));
1424         }
1425
1426         /* Get the code points valid only under UTF-8 locales */
1427         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1428             && ary[2] && ary[2] != &PL_sv_undef)
1429         {
1430             only_utf8_locale_invlist = ary[2];
1431         }
1432     }
1433
1434     if (! invlist) {
1435         invlist = sv_2mortal(_new_invlist(0));
1436     }
1437
1438     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1439      * code points, and an inversion list for the others, but if there are code
1440      * points that should match only conditionally on the target string being
1441      * UTF-8, those are placed in the inversion list, and not the bitmap.
1442      * Since there are circumstances under which they could match, they are
1443      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1444      * to exclude them here, so that when we invert below, the end result
1445      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1446      * have to do this here before we add the unconditionally matched code
1447      * points */
1448     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1449         _invlist_intersection_complement_2nd(invlist,
1450                                              PL_UpperLatin1,
1451                                              &invlist);
1452     }
1453
1454     /* Add in the points from the bit map */
1455     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1456         if (ANYOF_BITMAP_TEST(node, i)) {
1457             unsigned int start = i++;
1458
1459             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1460                 /* empty */
1461             }
1462             invlist = _add_range_to_invlist(invlist, start, i-1);
1463             new_node_has_latin1 = TRUE;
1464         }
1465     }
1466
1467     /* If this can match all upper Latin1 code points, have to add them
1468      * as well.  But don't add them if inverting, as when that gets done below,
1469      * it would exclude all these characters, including the ones it shouldn't
1470      * that were added just above */
1471     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1472         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1473     {
1474         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1475     }
1476
1477     /* Similarly for these */
1478     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1479         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1480     }
1481
1482     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1483         _invlist_invert(invlist);
1484     }
1485     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1486
1487         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1488          * locale.  We can skip this if there are no 0-255 at all. */
1489         _invlist_union(invlist, PL_Latin1, &invlist);
1490     }
1491
1492     /* Similarly add the UTF-8 locale possible matches.  These have to be
1493      * deferred until after the non-UTF-8 locale ones are taken care of just
1494      * above, or it leads to wrong results under ANYOF_INVERT */
1495     if (only_utf8_locale_invlist) {
1496         _invlist_union_maybe_complement_2nd(invlist,
1497                                             only_utf8_locale_invlist,
1498                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1499                                             &invlist);
1500     }
1501
1502     return invlist;
1503 }
1504
1505 /* These two functions currently do the exact same thing */
1506 #define ssc_init_zero           ssc_init
1507
1508 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1509 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1510
1511 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1512  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1513  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1514
1515 STATIC void
1516 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1517                 const regnode_charclass *and_with)
1518 {
1519     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1520      * another SSC or a regular ANYOF class.  Can create false positives. */
1521
1522     SV* anded_cp_list;
1523     U8  anded_flags;
1524
1525     PERL_ARGS_ASSERT_SSC_AND;
1526
1527     assert(is_ANYOF_SYNTHETIC(ssc));
1528
1529     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1530      * the code point inversion list and just the relevant flags */
1531     if (is_ANYOF_SYNTHETIC(and_with)) {
1532         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1533         anded_flags = ANYOF_FLAGS(and_with);
1534
1535         /* XXX This is a kludge around what appears to be deficiencies in the
1536          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1537          * there are paths through the optimizer where it doesn't get weeded
1538          * out when it should.  And if we don't make some extra provision for
1539          * it like the code just below, it doesn't get added when it should.
1540          * This solution is to add it only when AND'ing, which is here, and
1541          * only when what is being AND'ed is the pristine, original node
1542          * matching anything.  Thus it is like adding it to ssc_anything() but
1543          * only when the result is to be AND'ed.  Probably the same solution
1544          * could be adopted for the same problem we have with /l matching,
1545          * which is solved differently in S_ssc_init(), and that would lead to
1546          * fewer false positives than that solution has.  But if this solution
1547          * creates bugs, the consequences are only that a warning isn't raised
1548          * that should be; while the consequences for having /l bugs is
1549          * incorrect matches */
1550         if (ssc_is_anything((regnode_ssc *)and_with)) {
1551             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1552         }
1553     }
1554     else {
1555         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1556         if (OP(and_with) == ANYOFD) {
1557             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1558         }
1559         else {
1560             anded_flags = ANYOF_FLAGS(and_with)
1561             &( ANYOF_COMMON_FLAGS
1562               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1563               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1564             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1565                 anded_flags &=
1566                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1567             }
1568         }
1569     }
1570
1571     ANYOF_FLAGS(ssc) &= anded_flags;
1572
1573     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1574      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1575      * 'and_with' may be inverted.  When not inverted, we have the situation of
1576      * computing:
1577      *  (C1 | P1) & (C2 | P2)
1578      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1579      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1580      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1581      *                    <=  ((C1 & C2) | P1 | P2)
1582      * Alternatively, the last few steps could be:
1583      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1584      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1585      *                    <=  (C1 | C2 | (P1 & P2))
1586      * We favor the second approach if either P1 or P2 is non-empty.  This is
1587      * because these components are a barrier to doing optimizations, as what
1588      * they match cannot be known until the moment of matching as they are
1589      * dependent on the current locale, 'AND"ing them likely will reduce or
1590      * eliminate them.
1591      * But we can do better if we know that C1,P1 are in their initial state (a
1592      * frequent occurrence), each matching everything:
1593      *  (<everything>) & (C2 | P2) =  C2 | P2
1594      * Similarly, if C2,P2 are in their initial state (again a frequent
1595      * occurrence), the result is a no-op
1596      *  (C1 | P1) & (<everything>) =  C1 | P1
1597      *
1598      * Inverted, we have
1599      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1600      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1601      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1602      * */
1603
1604     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1605         && ! is_ANYOF_SYNTHETIC(and_with))
1606     {
1607         unsigned int i;
1608
1609         ssc_intersection(ssc,
1610                          anded_cp_list,
1611                          FALSE /* Has already been inverted */
1612                          );
1613
1614         /* If either P1 or P2 is empty, the intersection will be also; can skip
1615          * the loop */
1616         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1617             ANYOF_POSIXL_ZERO(ssc);
1618         }
1619         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1620
1621             /* Note that the Posix class component P from 'and_with' actually
1622              * looks like:
1623              *      P = Pa | Pb | ... | Pn
1624              * where each component is one posix class, such as in [\w\s].
1625              * Thus
1626              *      ~P = ~(Pa | Pb | ... | Pn)
1627              *         = ~Pa & ~Pb & ... & ~Pn
1628              *        <= ~Pa | ~Pb | ... | ~Pn
1629              * The last is something we can easily calculate, but unfortunately
1630              * is likely to have many false positives.  We could do better
1631              * in some (but certainly not all) instances if two classes in
1632              * P have known relationships.  For example
1633              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1634              * So
1635              *      :lower: & :print: = :lower:
1636              * And similarly for classes that must be disjoint.  For example,
1637              * since \s and \w can have no elements in common based on rules in
1638              * the POSIX standard,
1639              *      \w & ^\S = nothing
1640              * Unfortunately, some vendor locales do not meet the Posix
1641              * standard, in particular almost everything by Microsoft.
1642              * The loop below just changes e.g., \w into \W and vice versa */
1643
1644             regnode_charclass_posixl temp;
1645             int add = 1;    /* To calculate the index of the complement */
1646
1647             ANYOF_POSIXL_ZERO(&temp);
1648             for (i = 0; i < ANYOF_MAX; i++) {
1649                 assert(i % 2 != 0
1650                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1651                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1652
1653                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1654                     ANYOF_POSIXL_SET(&temp, i + add);
1655                 }
1656                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1657             }
1658             ANYOF_POSIXL_AND(&temp, ssc);
1659
1660         } /* else ssc already has no posixes */
1661     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1662          in its initial state */
1663     else if (! is_ANYOF_SYNTHETIC(and_with)
1664              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1665     {
1666         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1667          * copy it over 'ssc' */
1668         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1669             if (is_ANYOF_SYNTHETIC(and_with)) {
1670                 StructCopy(and_with, ssc, regnode_ssc);
1671             }
1672             else {
1673                 ssc->invlist = anded_cp_list;
1674                 ANYOF_POSIXL_ZERO(ssc);
1675                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1676                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1677                 }
1678             }
1679         }
1680         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1681                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1682         {
1683             /* One or the other of P1, P2 is non-empty. */
1684             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1685                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1686             }
1687             ssc_union(ssc, anded_cp_list, FALSE);
1688         }
1689         else { /* P1 = P2 = empty */
1690             ssc_intersection(ssc, anded_cp_list, FALSE);
1691         }
1692     }
1693 }
1694
1695 STATIC void
1696 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1697                const regnode_charclass *or_with)
1698 {
1699     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1700      * another SSC or a regular ANYOF class.  Can create false positives if
1701      * 'or_with' is to be inverted. */
1702
1703     SV* ored_cp_list;
1704     U8 ored_flags;
1705
1706     PERL_ARGS_ASSERT_SSC_OR;
1707
1708     assert(is_ANYOF_SYNTHETIC(ssc));
1709
1710     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1711      * the code point inversion list and just the relevant flags */
1712     if (is_ANYOF_SYNTHETIC(or_with)) {
1713         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1714         ored_flags = ANYOF_FLAGS(or_with);
1715     }
1716     else {
1717         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1718         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1719         if (OP(or_with) != ANYOFD) {
1720             ored_flags
1721             |= ANYOF_FLAGS(or_with)
1722              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1723                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1724             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1725                 ored_flags |=
1726                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1727             }
1728         }
1729     }
1730
1731     ANYOF_FLAGS(ssc) |= ored_flags;
1732
1733     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1734      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1735      * 'or_with' may be inverted.  When not inverted, we have the simple
1736      * situation of computing:
1737      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1738      * If P1|P2 yields a situation with both a class and its complement are
1739      * set, like having both \w and \W, this matches all code points, and we
1740      * can delete these from the P component of the ssc going forward.  XXX We
1741      * might be able to delete all the P components, but I (khw) am not certain
1742      * about this, and it is better to be safe.
1743      *
1744      * Inverted, we have
1745      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1746      *                         <=  (C1 | P1) | ~C2
1747      *                         <=  (C1 | ~C2) | P1
1748      * (which results in actually simpler code than the non-inverted case)
1749      * */
1750
1751     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1752         && ! is_ANYOF_SYNTHETIC(or_with))
1753     {
1754         /* We ignore P2, leaving P1 going forward */
1755     }   /* else  Not inverted */
1756     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1757         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1758         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1759             unsigned int i;
1760             for (i = 0; i < ANYOF_MAX; i += 2) {
1761                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1762                 {
1763                     ssc_match_all_cp(ssc);
1764                     ANYOF_POSIXL_CLEAR(ssc, i);
1765                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1766                 }
1767             }
1768         }
1769     }
1770
1771     ssc_union(ssc,
1772               ored_cp_list,
1773               FALSE /* Already has been inverted */
1774               );
1775 }
1776
1777 PERL_STATIC_INLINE void
1778 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1779 {
1780     PERL_ARGS_ASSERT_SSC_UNION;
1781
1782     assert(is_ANYOF_SYNTHETIC(ssc));
1783
1784     _invlist_union_maybe_complement_2nd(ssc->invlist,
1785                                         invlist,
1786                                         invert2nd,
1787                                         &ssc->invlist);
1788 }
1789
1790 PERL_STATIC_INLINE void
1791 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1792                          SV* const invlist,
1793                          const bool invert2nd)
1794 {
1795     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1796
1797     assert(is_ANYOF_SYNTHETIC(ssc));
1798
1799     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1800                                                invlist,
1801                                                invert2nd,
1802                                                &ssc->invlist);
1803 }
1804
1805 PERL_STATIC_INLINE void
1806 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1807 {
1808     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1809
1810     assert(is_ANYOF_SYNTHETIC(ssc));
1811
1812     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1813 }
1814
1815 PERL_STATIC_INLINE void
1816 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1817 {
1818     /* AND just the single code point 'cp' into the SSC 'ssc' */
1819
1820     SV* cp_list = _new_invlist(2);
1821
1822     PERL_ARGS_ASSERT_SSC_CP_AND;
1823
1824     assert(is_ANYOF_SYNTHETIC(ssc));
1825
1826     cp_list = add_cp_to_invlist(cp_list, cp);
1827     ssc_intersection(ssc, cp_list,
1828                      FALSE /* Not inverted */
1829                      );
1830     SvREFCNT_dec_NN(cp_list);
1831 }
1832
1833 PERL_STATIC_INLINE void
1834 S_ssc_clear_locale(regnode_ssc *ssc)
1835 {
1836     /* Set the SSC 'ssc' to not match any locale things */
1837     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1838
1839     assert(is_ANYOF_SYNTHETIC(ssc));
1840
1841     ANYOF_POSIXL_ZERO(ssc);
1842     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1843 }
1844
1845 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1846
1847 STATIC bool
1848 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1849 {
1850     /* The synthetic start class is used to hopefully quickly winnow down
1851      * places where a pattern could start a match in the target string.  If it
1852      * doesn't really narrow things down that much, there isn't much point to
1853      * having the overhead of using it.  This function uses some very crude
1854      * heuristics to decide if to use the ssc or not.
1855      *
1856      * It returns TRUE if 'ssc' rules out more than half what it considers to
1857      * be the "likely" possible matches, but of course it doesn't know what the
1858      * actual things being matched are going to be; these are only guesses
1859      *
1860      * For /l matches, it assumes that the only likely matches are going to be
1861      *      in the 0-255 range, uniformly distributed, so half of that is 127
1862      * For /a and /d matches, it assumes that the likely matches will be just
1863      *      the ASCII range, so half of that is 63
1864      * For /u and there isn't anything matching above the Latin1 range, it
1865      *      assumes that that is the only range likely to be matched, and uses
1866      *      half that as the cut-off: 127.  If anything matches above Latin1,
1867      *      it assumes that all of Unicode could match (uniformly), except for
1868      *      non-Unicode code points and things in the General Category "Other"
1869      *      (unassigned, private use, surrogates, controls and formats).  This
1870      *      is a much large number. */
1871
1872     U32 count = 0;      /* Running total of number of code points matched by
1873                            'ssc' */
1874     UV start, end;      /* Start and end points of current range in inversion
1875                            list */
1876     const U32 max_code_points = (LOC)
1877                                 ?  256
1878                                 : ((   ! UNI_SEMANTICS
1879                                      || invlist_highest(ssc->invlist) < 256)
1880                                   ? 128
1881                                   : NON_OTHER_COUNT);
1882     const U32 max_match = max_code_points / 2;
1883
1884     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1885
1886     invlist_iterinit(ssc->invlist);
1887     while (invlist_iternext(ssc->invlist, &start, &end)) {
1888         if (start >= max_code_points) {
1889             break;
1890         }
1891         end = MIN(end, max_code_points - 1);
1892         count += end - start + 1;
1893         if (count >= max_match) {
1894             invlist_iterfinish(ssc->invlist);
1895             return FALSE;
1896         }
1897     }
1898
1899     return TRUE;
1900 }
1901
1902
1903 STATIC void
1904 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1905 {
1906     /* The inversion list in the SSC is marked mortal; now we need a more
1907      * permanent copy, which is stored the same way that is done in a regular
1908      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1909      * map */
1910
1911     SV* invlist = invlist_clone(ssc->invlist);
1912
1913     PERL_ARGS_ASSERT_SSC_FINALIZE;
1914
1915     assert(is_ANYOF_SYNTHETIC(ssc));
1916
1917     /* The code in this file assumes that all but these flags aren't relevant
1918      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1919      * by the time we reach here */
1920     assert(! (ANYOF_FLAGS(ssc)
1921         & ~( ANYOF_COMMON_FLAGS
1922             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1923             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
1924
1925     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1926
1927     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1928                                 NULL, NULL, NULL, FALSE);
1929
1930     /* Make sure is clone-safe */
1931     ssc->invlist = NULL;
1932
1933     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1934         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1935     }
1936
1937     if (RExC_contains_locale) {
1938         OP(ssc) = ANYOFL;
1939     }
1940
1941     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1942 }
1943
1944 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1945 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1946 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1947 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1948                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1949                                : 0 )
1950
1951
1952 #ifdef DEBUGGING
1953 /*
1954    dump_trie(trie,widecharmap,revcharmap)
1955    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1956    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1957
1958    These routines dump out a trie in a somewhat readable format.
1959    The _interim_ variants are used for debugging the interim
1960    tables that are used to generate the final compressed
1961    representation which is what dump_trie expects.
1962
1963    Part of the reason for their existence is to provide a form
1964    of documentation as to how the different representations function.
1965
1966 */
1967
1968 /*
1969   Dumps the final compressed table form of the trie to Perl_debug_log.
1970   Used for debugging make_trie().
1971 */
1972
1973 STATIC void
1974 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1975             AV *revcharmap, U32 depth)
1976 {
1977     U32 state;
1978     SV *sv=sv_newmortal();
1979     int colwidth= widecharmap ? 6 : 4;
1980     U16 word;
1981     GET_RE_DEBUG_FLAGS_DECL;
1982
1983     PERL_ARGS_ASSERT_DUMP_TRIE;
1984
1985     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
1986         depth+1, "Match","Base","Ofs" );
1987
1988     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1989         SV ** const tmp = av_fetch( revcharmap, state, 0);
1990         if ( tmp ) {
1991             Perl_re_printf( aTHX_  "%*s",
1992                 colwidth,
1993                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1994                             PL_colors[0], PL_colors[1],
1995                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1996                             PERL_PV_ESCAPE_FIRSTCHAR
1997                 )
1998             );
1999         }
2000     }
2001     Perl_re_printf( aTHX_  "\n");
2002     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2003
2004     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2005         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2006     Perl_re_printf( aTHX_  "\n");
2007
2008     for( state = 1 ; state < trie->statecount ; state++ ) {
2009         const U32 base = trie->states[ state ].trans.base;
2010
2011         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2012
2013         if ( trie->states[ state ].wordnum ) {
2014             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2015         } else {
2016             Perl_re_printf( aTHX_  "%6s", "" );
2017         }
2018
2019         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2020
2021         if ( base ) {
2022             U32 ofs = 0;
2023
2024             while( ( base + ofs  < trie->uniquecharcount ) ||
2025                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2026                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2027                                                                     != state))
2028                     ofs++;
2029
2030             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2031
2032             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2033                 if ( ( base + ofs >= trie->uniquecharcount )
2034                         && ( base + ofs - trie->uniquecharcount
2035                                                         < trie->lasttrans )
2036                         && trie->trans[ base + ofs
2037                                     - trie->uniquecharcount ].check == state )
2038                 {
2039                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2040                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2041                    );
2042                 } else {
2043                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2044                 }
2045             }
2046
2047             Perl_re_printf( aTHX_  "]");
2048
2049         }
2050         Perl_re_printf( aTHX_  "\n" );
2051     }
2052     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2053                                 depth);
2054     for (word=1; word <= trie->wordcount; word++) {
2055         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2056             (int)word, (int)(trie->wordinfo[word].prev),
2057             (int)(trie->wordinfo[word].len));
2058     }
2059     Perl_re_printf( aTHX_  "\n" );
2060 }
2061 /*
2062   Dumps a fully constructed but uncompressed trie in list form.
2063   List tries normally only are used for construction when the number of
2064   possible chars (trie->uniquecharcount) is very high.
2065   Used for debugging make_trie().
2066 */
2067 STATIC void
2068 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2069                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2070                          U32 depth)
2071 {
2072     U32 state;
2073     SV *sv=sv_newmortal();
2074     int colwidth= widecharmap ? 6 : 4;
2075     GET_RE_DEBUG_FLAGS_DECL;
2076
2077     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2078
2079     /* print out the table precompression.  */
2080     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2081             depth+1 );
2082     Perl_re_indentf( aTHX_  "%s",
2083             depth+1, "------:-----+-----------------\n" );
2084
2085     for( state=1 ; state < next_alloc ; state ++ ) {
2086         U16 charid;
2087
2088         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2089             depth+1, (UV)state  );
2090         if ( ! trie->states[ state ].wordnum ) {
2091             Perl_re_printf( aTHX_  "%5s| ","");
2092         } else {
2093             Perl_re_printf( aTHX_  "W%4x| ",
2094                 trie->states[ state ].wordnum
2095             );
2096         }
2097         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2098             SV ** const tmp = av_fetch( revcharmap,
2099                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2100             if ( tmp ) {
2101                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2102                     colwidth,
2103                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2104                               colwidth,
2105                               PL_colors[0], PL_colors[1],
2106                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2107                               | PERL_PV_ESCAPE_FIRSTCHAR
2108                     ) ,
2109                     TRIE_LIST_ITEM(state,charid).forid,
2110                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2111                 );
2112                 if (!(charid % 10))
2113                     Perl_re_printf( aTHX_  "\n%*s| ",
2114                         (int)((depth * 2) + 14), "");
2115             }
2116         }
2117         Perl_re_printf( aTHX_  "\n");
2118     }
2119 }
2120
2121 /*
2122   Dumps a fully constructed but uncompressed trie in table form.
2123   This is the normal DFA style state transition table, with a few
2124   twists to facilitate compression later.
2125   Used for debugging make_trie().
2126 */
2127 STATIC void
2128 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2129                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2130                           U32 depth)
2131 {
2132     U32 state;
2133     U16 charid;
2134     SV *sv=sv_newmortal();
2135     int colwidth= widecharmap ? 6 : 4;
2136     GET_RE_DEBUG_FLAGS_DECL;
2137
2138     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2139
2140     /*
2141        print out the table precompression so that we can do a visual check
2142        that they are identical.
2143      */
2144
2145     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2146
2147     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2148         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2149         if ( tmp ) {
2150             Perl_re_printf( aTHX_  "%*s",
2151                 colwidth,
2152                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2153                             PL_colors[0], PL_colors[1],
2154                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2155                             PERL_PV_ESCAPE_FIRSTCHAR
2156                 )
2157             );
2158         }
2159     }
2160
2161     Perl_re_printf( aTHX_ "\n");
2162     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2163
2164     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2165         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2166     }
2167
2168     Perl_re_printf( aTHX_  "\n" );
2169
2170     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2171
2172         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2173             depth+1,
2174             (UV)TRIE_NODENUM( state ) );
2175
2176         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2177             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2178             if (v)
2179                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2180             else
2181                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2182         }
2183         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2184             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2185                                             (UV)trie->trans[ state ].check );
2186         } else {
2187             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2188                                             (UV)trie->trans[ state ].check,
2189             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2190         }
2191     }
2192 }
2193
2194 #endif
2195
2196
2197 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2198   startbranch: the first branch in the whole branch sequence
2199   first      : start branch of sequence of branch-exact nodes.
2200                May be the same as startbranch
2201   last       : Thing following the last branch.
2202                May be the same as tail.
2203   tail       : item following the branch sequence
2204   count      : words in the sequence
2205   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2206   depth      : indent depth
2207
2208 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2209
2210 A trie is an N'ary tree where the branches are determined by digital
2211 decomposition of the key. IE, at the root node you look up the 1st character and
2212 follow that branch repeat until you find the end of the branches. Nodes can be
2213 marked as "accepting" meaning they represent a complete word. Eg:
2214
2215   /he|she|his|hers/
2216
2217 would convert into the following structure. Numbers represent states, letters
2218 following numbers represent valid transitions on the letter from that state, if
2219 the number is in square brackets it represents an accepting state, otherwise it
2220 will be in parenthesis.
2221
2222       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2223       |    |
2224       |   (2)
2225       |    |
2226      (1)   +-i->(6)-+-s->[7]
2227       |
2228       +-s->(3)-+-h->(4)-+-e->[5]
2229
2230       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2231
2232 This shows that when matching against the string 'hers' we will begin at state 1
2233 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2234 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2235 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2236 single traverse. We store a mapping from accepting to state to which word was
2237 matched, and then when we have multiple possibilities we try to complete the
2238 rest of the regex in the order in which they occurred in the alternation.
2239
2240 The only prior NFA like behaviour that would be changed by the TRIE support is
2241 the silent ignoring of duplicate alternations which are of the form:
2242
2243  / (DUPE|DUPE) X? (?{ ... }) Y /x
2244
2245 Thus EVAL blocks following a trie may be called a different number of times with
2246 and without the optimisation. With the optimisations dupes will be silently
2247 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2248 the following demonstrates:
2249
2250  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2251
2252 which prints out 'word' three times, but
2253
2254  'words'=~/(word|word|word)(?{ print $1 })S/
2255
2256 which doesnt print it out at all. This is due to other optimisations kicking in.
2257
2258 Example of what happens on a structural level:
2259
2260 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2261
2262    1: CURLYM[1] {1,32767}(18)
2263    5:   BRANCH(8)
2264    6:     EXACT <ac>(16)
2265    8:   BRANCH(11)
2266    9:     EXACT <ad>(16)
2267   11:   BRANCH(14)
2268   12:     EXACT <ab>(16)
2269   16:   SUCCEED(0)
2270   17:   NOTHING(18)
2271   18: END(0)
2272
2273 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2274 and should turn into:
2275
2276    1: CURLYM[1] {1,32767}(18)
2277    5:   TRIE(16)
2278         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2279           <ac>
2280           <ad>
2281           <ab>
2282   16:   SUCCEED(0)
2283   17:   NOTHING(18)
2284   18: END(0)
2285
2286 Cases where tail != last would be like /(?foo|bar)baz/:
2287
2288    1: BRANCH(4)
2289    2:   EXACT <foo>(8)
2290    4: BRANCH(7)
2291    5:   EXACT <bar>(8)
2292    7: TAIL(8)
2293    8: EXACT <baz>(10)
2294   10: END(0)
2295
2296 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2297 and would end up looking like:
2298
2299     1: TRIE(8)
2300       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2301         <foo>
2302         <bar>
2303    7: TAIL(8)
2304    8: EXACT <baz>(10)
2305   10: END(0)
2306
2307     d = uvchr_to_utf8_flags(d, uv, 0);
2308
2309 is the recommended Unicode-aware way of saying
2310
2311     *(d++) = uv;
2312 */
2313
2314 #define TRIE_STORE_REVCHAR(val)                                            \
2315     STMT_START {                                                           \
2316         if (UTF) {                                                         \
2317             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2318             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2319             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2320             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2321             SvPOK_on(zlopp);                                               \
2322             SvUTF8_on(zlopp);                                              \
2323             av_push(revcharmap, zlopp);                                    \
2324         } else {                                                           \
2325             char ooooff = (char)val;                                           \
2326             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2327         }                                                                  \
2328         } STMT_END
2329
2330 /* This gets the next character from the input, folding it if not already
2331  * folded. */
2332 #define TRIE_READ_CHAR STMT_START {                                           \
2333     wordlen++;                                                                \
2334     if ( UTF ) {                                                              \
2335         /* if it is UTF then it is either already folded, or does not need    \
2336          * folding */                                                         \
2337         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2338     }                                                                         \
2339     else if (folder == PL_fold_latin1) {                                      \
2340         /* This folder implies Unicode rules, which in the range expressible  \
2341          *  by not UTF is the lower case, with the two exceptions, one of     \
2342          *  which should have been taken care of before calling this */       \
2343         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2344         uvc = toLOWER_L1(*uc);                                                \
2345         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2346         len = 1;                                                              \
2347     } else {                                                                  \
2348         /* raw data, will be folded later if needed */                        \
2349         uvc = (U32)*uc;                                                       \
2350         len = 1;                                                              \
2351     }                                                                         \
2352 } STMT_END
2353
2354
2355
2356 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2357     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2358         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
2359         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2360     }                                                           \
2361     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2362     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2363     TRIE_LIST_CUR( state )++;                                   \
2364 } STMT_END
2365
2366 #define TRIE_LIST_NEW(state) STMT_START {                       \
2367     Newxz( trie->states[ state ].trans.list,               \
2368         4, reg_trie_trans_le );                                 \
2369      TRIE_LIST_CUR( state ) = 1;                                \
2370      TRIE_LIST_LEN( state ) = 4;                                \
2371 } STMT_END
2372
2373 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2374     U16 dupe= trie->states[ state ].wordnum;                    \
2375     regnode * const noper_next = regnext( noper );              \
2376                                                                 \
2377     DEBUG_r({                                                   \
2378         /* store the word for dumping */                        \
2379         SV* tmp;                                                \
2380         if (OP(noper) != NOTHING)                               \
2381             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2382         else                                                    \
2383             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2384         av_push( trie_words, tmp );                             \
2385     });                                                         \
2386                                                                 \
2387     curword++;                                                  \
2388     trie->wordinfo[curword].prev   = 0;                         \
2389     trie->wordinfo[curword].len    = wordlen;                   \
2390     trie->wordinfo[curword].accept = state;                     \
2391                                                                 \
2392     if ( noper_next < tail ) {                                  \
2393         if (!trie->jump)                                        \
2394             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2395                                                  sizeof(U16) ); \
2396         trie->jump[curword] = (U16)(noper_next - convert);      \
2397         if (!jumper)                                            \
2398             jumper = noper_next;                                \
2399         if (!nextbranch)                                        \
2400             nextbranch= regnext(cur);                           \
2401     }                                                           \
2402                                                                 \
2403     if ( dupe ) {                                               \
2404         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2405         /* chain, so that when the bits of chain are later    */\
2406         /* linked together, the dups appear in the chain      */\
2407         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2408         trie->wordinfo[dupe].prev = curword;                    \
2409     } else {                                                    \
2410         /* we haven't inserted this word yet.                */ \
2411         trie->states[ state ].wordnum = curword;                \
2412     }                                                           \
2413 } STMT_END
2414
2415
2416 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2417      ( ( base + charid >=  ucharcount                                   \
2418          && base + charid < ubound                                      \
2419          && state == trie->trans[ base - ucharcount + charid ].check    \
2420          && trie->trans[ base - ucharcount + charid ].next )            \
2421            ? trie->trans[ base - ucharcount + charid ].next             \
2422            : ( state==1 ? special : 0 )                                 \
2423       )
2424
2425 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2426 STMT_START {                                                \
2427     TRIE_BITMAP_SET(trie, uvc);                             \
2428     /* store the folded codepoint */                        \
2429     if ( folder )                                           \
2430         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2431                                                             \
2432     if ( !UTF ) {                                           \
2433         /* store first byte of utf8 representation of */    \
2434         /* variant codepoints */                            \
2435         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2436             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2437         }                                                   \
2438     }                                                       \
2439 } STMT_END
2440 #define MADE_TRIE       1
2441 #define MADE_JUMP_TRIE  2
2442 #define MADE_EXACT_TRIE 4
2443
2444 STATIC I32
2445 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2446                   regnode *first, regnode *last, regnode *tail,
2447                   U32 word_count, U32 flags, U32 depth)
2448 {
2449     /* first pass, loop through and scan words */
2450     reg_trie_data *trie;
2451     HV *widecharmap = NULL;
2452     AV *revcharmap = newAV();
2453     regnode *cur;
2454     STRLEN len = 0;
2455     UV uvc = 0;
2456     U16 curword = 0;
2457     U32 next_alloc = 0;
2458     regnode *jumper = NULL;
2459     regnode *nextbranch = NULL;
2460     regnode *convert = NULL;
2461     U32 *prev_states; /* temp array mapping each state to previous one */
2462     /* we just use folder as a flag in utf8 */
2463     const U8 * folder = NULL;
2464
2465 #ifdef DEBUGGING
2466     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2467     AV *trie_words = NULL;
2468     /* along with revcharmap, this only used during construction but both are
2469      * useful during debugging so we store them in the struct when debugging.
2470      */
2471 #else
2472     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2473     STRLEN trie_charcount=0;
2474 #endif
2475     SV *re_trie_maxbuff;
2476     GET_RE_DEBUG_FLAGS_DECL;
2477
2478     PERL_ARGS_ASSERT_MAKE_TRIE;
2479 #ifndef DEBUGGING
2480     PERL_UNUSED_ARG(depth);
2481 #endif
2482
2483     switch (flags) {
2484         case EXACT: case EXACTL: break;
2485         case EXACTFA:
2486         case EXACTFU_SS:
2487         case EXACTFU:
2488         case EXACTFLU8: folder = PL_fold_latin1; break;
2489         case EXACTF:  folder = PL_fold; break;
2490         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2491     }
2492
2493     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2494     trie->refcount = 1;
2495     trie->startstate = 1;
2496     trie->wordcount = word_count;
2497     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2498     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2499     if (flags == EXACT || flags == EXACTL)
2500         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2501     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2502                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2503
2504     DEBUG_r({
2505         trie_words = newAV();
2506     });
2507
2508     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2509     assert(re_trie_maxbuff);
2510     if (!SvIOK(re_trie_maxbuff)) {
2511         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2512     }
2513     DEBUG_TRIE_COMPILE_r({
2514         Perl_re_indentf( aTHX_
2515           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2516           depth+1,
2517           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2518           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2519     });
2520
2521    /* Find the node we are going to overwrite */
2522     if ( first == startbranch && OP( last ) != BRANCH ) {
2523         /* whole branch chain */
2524         convert = first;
2525     } else {
2526         /* branch sub-chain */
2527         convert = NEXTOPER( first );
2528     }
2529
2530     /*  -- First loop and Setup --
2531
2532        We first traverse the branches and scan each word to determine if it
2533        contains widechars, and how many unique chars there are, this is
2534        important as we have to build a table with at least as many columns as we
2535        have unique chars.
2536
2537        We use an array of integers to represent the character codes 0..255
2538        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2539        the native representation of the character value as the key and IV's for
2540        the coded index.
2541
2542        *TODO* If we keep track of how many times each character is used we can
2543        remap the columns so that the table compression later on is more
2544        efficient in terms of memory by ensuring the most common value is in the
2545        middle and the least common are on the outside.  IMO this would be better
2546        than a most to least common mapping as theres a decent chance the most
2547        common letter will share a node with the least common, meaning the node
2548        will not be compressible. With a middle is most common approach the worst
2549        case is when we have the least common nodes twice.
2550
2551      */
2552
2553     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2554         regnode *noper = NEXTOPER( cur );
2555         const U8 *uc;
2556         const U8 *e;
2557         int foldlen = 0;
2558         U32 wordlen      = 0;         /* required init */
2559         STRLEN minchars = 0;
2560         STRLEN maxchars = 0;
2561         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2562                                                bitmap?*/
2563
2564         if (OP(noper) == NOTHING) {
2565             /* skip past a NOTHING at the start of an alternation
2566              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2567              */
2568             regnode *noper_next= regnext(noper);
2569             if (noper_next < tail)
2570                 noper= noper_next;
2571         }
2572
2573         if ( noper < tail &&
2574                 (
2575                     OP(noper) == flags ||
2576                     (
2577                         flags == EXACTFU &&
2578                         OP(noper) == EXACTFU_SS
2579                     )
2580                 )
2581         ) {
2582             uc= (U8*)STRING(noper);
2583             e= uc + STR_LEN(noper);
2584         } else {
2585             trie->minlen= 0;
2586             continue;
2587         }
2588
2589
2590         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2591             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2592                                           regardless of encoding */
2593             if (OP( noper ) == EXACTFU_SS) {
2594                 /* false positives are ok, so just set this */
2595                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2596             }
2597         }
2598
2599         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2600                                            branch */
2601             TRIE_CHARCOUNT(trie)++;
2602             TRIE_READ_CHAR;
2603
2604             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2605              * is in effect.  Under /i, this character can match itself, or
2606              * anything that folds to it.  If not under /i, it can match just
2607              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2608              * all fold to k, and all are single characters.   But some folds
2609              * expand to more than one character, so for example LATIN SMALL
2610              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2611              * the string beginning at 'uc' is 'ffi', it could be matched by
2612              * three characters, or just by the one ligature character. (It
2613              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2614              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2615              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2616              * match.)  The trie needs to know the minimum and maximum number
2617              * of characters that could match so that it can use size alone to
2618              * quickly reject many match attempts.  The max is simple: it is
2619              * the number of folded characters in this branch (since a fold is
2620              * never shorter than what folds to it. */
2621
2622             maxchars++;
2623
2624             /* And the min is equal to the max if not under /i (indicated by
2625              * 'folder' being NULL), or there are no multi-character folds.  If
2626              * there is a multi-character fold, the min is incremented just
2627              * once, for the character that folds to the sequence.  Each
2628              * character in the sequence needs to be added to the list below of
2629              * characters in the trie, but we count only the first towards the
2630              * min number of characters needed.  This is done through the
2631              * variable 'foldlen', which is returned by the macros that look
2632              * for these sequences as the number of bytes the sequence
2633              * occupies.  Each time through the loop, we decrement 'foldlen' by
2634              * how many bytes the current char occupies.  Only when it reaches
2635              * 0 do we increment 'minchars' or look for another multi-character
2636              * sequence. */
2637             if (folder == NULL) {
2638                 minchars++;
2639             }
2640             else if (foldlen > 0) {
2641                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2642             }
2643             else {
2644                 minchars++;
2645
2646                 /* See if *uc is the beginning of a multi-character fold.  If
2647                  * so, we decrement the length remaining to look at, to account
2648                  * for the current character this iteration.  (We can use 'uc'
2649                  * instead of the fold returned by TRIE_READ_CHAR because for
2650                  * non-UTF, the latin1_safe macro is smart enough to account
2651                  * for all the unfolded characters, and because for UTF, the
2652                  * string will already have been folded earlier in the
2653                  * compilation process */
2654                 if (UTF) {
2655                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2656                         foldlen -= UTF8SKIP(uc);
2657                     }
2658                 }
2659                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2660                     foldlen--;
2661                 }
2662             }
2663
2664             /* The current character (and any potential folds) should be added
2665              * to the possible matching characters for this position in this
2666              * branch */
2667             if ( uvc < 256 ) {
2668                 if ( folder ) {
2669                     U8 folded= folder[ (U8) uvc ];
2670                     if ( !trie->charmap[ folded ] ) {
2671                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2672                         TRIE_STORE_REVCHAR( folded );
2673                     }
2674                 }
2675                 if ( !trie->charmap[ uvc ] ) {
2676                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2677                     TRIE_STORE_REVCHAR( uvc );
2678                 }
2679                 if ( set_bit ) {
2680                     /* store the codepoint in the bitmap, and its folded
2681                      * equivalent. */
2682                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2683                     set_bit = 0; /* We've done our bit :-) */
2684                 }
2685             } else {
2686
2687                 /* XXX We could come up with the list of code points that fold
2688                  * to this using PL_utf8_foldclosures, except not for
2689                  * multi-char folds, as there may be multiple combinations
2690                  * there that could work, which needs to wait until runtime to
2691                  * resolve (The comment about LIGATURE FFI above is such an
2692                  * example */
2693
2694                 SV** svpp;
2695                 if ( !widecharmap )
2696                     widecharmap = newHV();
2697
2698                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2699
2700                 if ( !svpp )
2701                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2702
2703                 if ( !SvTRUE( *svpp ) ) {
2704                     sv_setiv( *svpp, ++trie->uniquecharcount );
2705                     TRIE_STORE_REVCHAR(uvc);
2706                 }
2707             }
2708         } /* end loop through characters in this branch of the trie */
2709
2710         /* We take the min and max for this branch and combine to find the min
2711          * and max for all branches processed so far */
2712         if( cur == first ) {
2713             trie->minlen = minchars;
2714             trie->maxlen = maxchars;
2715         } else if (minchars < trie->minlen) {
2716             trie->minlen = minchars;
2717         } else if (maxchars > trie->maxlen) {
2718             trie->maxlen = maxchars;
2719         }
2720     } /* end first pass */
2721     DEBUG_TRIE_COMPILE_r(
2722         Perl_re_indentf( aTHX_
2723                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2724                 depth+1,
2725                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2726                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2727                 (int)trie->minlen, (int)trie->maxlen )
2728     );
2729
2730     /*
2731         We now know what we are dealing with in terms of unique chars and
2732         string sizes so we can calculate how much memory a naive
2733         representation using a flat table  will take. If it's over a reasonable
2734         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2735         conservative but potentially much slower representation using an array
2736         of lists.
2737
2738         At the end we convert both representations into the same compressed
2739         form that will be used in regexec.c for matching with. The latter
2740         is a form that cannot be used to construct with but has memory
2741         properties similar to the list form and access properties similar
2742         to the table form making it both suitable for fast searches and
2743         small enough that its feasable to store for the duration of a program.
2744
2745         See the comment in the code where the compressed table is produced
2746         inplace from the flat tabe representation for an explanation of how
2747         the compression works.
2748
2749     */
2750
2751
2752     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2753     prev_states[1] = 0;
2754
2755     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2756                                                     > SvIV(re_trie_maxbuff) )
2757     {
2758         /*
2759             Second Pass -- Array Of Lists Representation
2760
2761             Each state will be represented by a list of charid:state records
2762             (reg_trie_trans_le) the first such element holds the CUR and LEN
2763             points of the allocated array. (See defines above).
2764
2765             We build the initial structure using the lists, and then convert
2766             it into the compressed table form which allows faster lookups
2767             (but cant be modified once converted).
2768         */
2769
2770         STRLEN transcount = 1;
2771
2772         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2773             depth+1));
2774
2775         trie->states = (reg_trie_state *)
2776             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2777                                   sizeof(reg_trie_state) );
2778         TRIE_LIST_NEW(1);
2779         next_alloc = 2;
2780
2781         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2782
2783             regnode *noper   = NEXTOPER( cur );
2784             U32 state        = 1;         /* required init */
2785             U16 charid       = 0;         /* sanity init */
2786             U32 wordlen      = 0;         /* required init */
2787
2788             if (OP(noper) == NOTHING) {
2789                 regnode *noper_next= regnext(noper);
2790                 if (noper_next < tail)
2791                     noper= noper_next;
2792             }
2793
2794             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2795                 const U8 *uc= (U8*)STRING(noper);
2796                 const U8 *e= uc + STR_LEN(noper);
2797
2798                 for ( ; uc < e ; uc += len ) {
2799
2800                     TRIE_READ_CHAR;
2801
2802                     if ( uvc < 256 ) {
2803                         charid = trie->charmap[ uvc ];
2804                     } else {
2805                         SV** const svpp = hv_fetch( widecharmap,
2806                                                     (char*)&uvc,
2807                                                     sizeof( UV ),
2808                                                     0);
2809                         if ( !svpp ) {
2810                             charid = 0;
2811                         } else {
2812                             charid=(U16)SvIV( *svpp );
2813                         }
2814                     }
2815                     /* charid is now 0 if we dont know the char read, or
2816                      * nonzero if we do */
2817                     if ( charid ) {
2818
2819                         U16 check;
2820                         U32 newstate = 0;
2821
2822                         charid--;
2823                         if ( !trie->states[ state ].trans.list ) {
2824                             TRIE_LIST_NEW( state );
2825                         }
2826                         for ( check = 1;
2827                               check <= TRIE_LIST_USED( state );
2828                               check++ )
2829                         {
2830                             if ( TRIE_LIST_ITEM( state, check ).forid
2831                                                                     == charid )
2832                             {
2833                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2834                                 break;
2835                             }
2836                         }
2837                         if ( ! newstate ) {
2838                             newstate = next_alloc++;
2839                             prev_states[newstate] = state;
2840                             TRIE_LIST_PUSH( state, charid, newstate );
2841                             transcount++;
2842                         }
2843                         state = newstate;
2844                     } else {
2845                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2846                     }
2847                 }
2848             }
2849             TRIE_HANDLE_WORD(state);
2850
2851         } /* end second pass */
2852
2853         /* next alloc is the NEXT state to be allocated */
2854         trie->statecount = next_alloc;
2855         trie->states = (reg_trie_state *)
2856             PerlMemShared_realloc( trie->states,
2857                                    next_alloc
2858                                    * sizeof(reg_trie_state) );
2859
2860         /* and now dump it out before we compress it */
2861         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2862                                                          revcharmap, next_alloc,
2863                                                          depth+1)
2864         );
2865
2866         trie->trans = (reg_trie_trans *)
2867             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2868         {
2869             U32 state;
2870             U32 tp = 0;
2871             U32 zp = 0;
2872
2873
2874             for( state=1 ; state < next_alloc ; state ++ ) {
2875                 U32 base=0;
2876
2877                 /*
2878                 DEBUG_TRIE_COMPILE_MORE_r(
2879                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2880                 );
2881                 */
2882
2883                 if (trie->states[state].trans.list) {
2884                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2885                     U16 maxid=minid;
2886                     U16 idx;
2887
2888                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2889                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2890                         if ( forid < minid ) {
2891                             minid=forid;
2892                         } else if ( forid > maxid ) {
2893                             maxid=forid;
2894                         }
2895                     }
2896                     if ( transcount < tp + maxid - minid + 1) {
2897                         transcount *= 2;
2898                         trie->trans = (reg_trie_trans *)
2899                             PerlMemShared_realloc( trie->trans,
2900                                                      transcount
2901                                                      * sizeof(reg_trie_trans) );
2902                         Zero( trie->trans + (transcount / 2),
2903                               transcount / 2,
2904                               reg_trie_trans );
2905                     }
2906                     base = trie->uniquecharcount + tp - minid;
2907                     if ( maxid == minid ) {
2908                         U32 set = 0;
2909                         for ( ; zp < tp ; zp++ ) {
2910                             if ( ! trie->trans[ zp ].next ) {
2911                                 base = trie->uniquecharcount + zp - minid;
2912                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2913                                                                    1).newstate;
2914                                 trie->trans[ zp ].check = state;
2915                                 set = 1;
2916                                 break;
2917                             }
2918                         }
2919                         if ( !set ) {
2920                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2921                                                                    1).newstate;
2922                             trie->trans[ tp ].check = state;
2923                             tp++;
2924                             zp = tp;
2925                         }
2926                     } else {
2927                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2928                             const U32 tid = base
2929                                            - trie->uniquecharcount
2930                                            + TRIE_LIST_ITEM( state, idx ).forid;
2931                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2932                                                                 idx ).newstate;
2933                             trie->trans[ tid ].check = state;
2934                         }
2935                         tp += ( maxid - minid + 1 );
2936                     }
2937                     Safefree(trie->states[ state ].trans.list);
2938                 }
2939                 /*
2940                 DEBUG_TRIE_COMPILE_MORE_r(
2941                     Perl_re_printf( aTHX_  " base: %d\n",base);
2942                 );
2943                 */
2944                 trie->states[ state ].trans.base=base;
2945             }
2946             trie->lasttrans = tp + 1;
2947         }
2948     } else {
2949         /*
2950            Second Pass -- Flat Table Representation.
2951
2952            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2953            each.  We know that we will need Charcount+1 trans at most to store
2954            the data (one row per char at worst case) So we preallocate both
2955            structures assuming worst case.
2956
2957            We then construct the trie using only the .next slots of the entry
2958            structs.
2959
2960            We use the .check field of the first entry of the node temporarily
2961            to make compression both faster and easier by keeping track of how
2962            many non zero fields are in the node.
2963
2964            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2965            transition.
2966
2967            There are two terms at use here: state as a TRIE_NODEIDX() which is
2968            a number representing the first entry of the node, and state as a
2969            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2970            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2971            if there are 2 entrys per node. eg:
2972
2973              A B       A B
2974           1. 2 4    1. 3 7
2975           2. 0 3    3. 0 5
2976           3. 0 0    5. 0 0
2977           4. 0 0    7. 0 0
2978
2979            The table is internally in the right hand, idx form. However as we
2980            also have to deal with the states array which is indexed by nodenum
2981            we have to use TRIE_NODENUM() to convert.
2982
2983         */
2984         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
2985             depth+1));
2986
2987         trie->trans = (reg_trie_trans *)
2988             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2989                                   * trie->uniquecharcount + 1,
2990                                   sizeof(reg_trie_trans) );
2991         trie->states = (reg_trie_state *)
2992             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2993                                   sizeof(reg_trie_state) );
2994         next_alloc = trie->uniquecharcount + 1;
2995
2996
2997         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2998
2999             regnode *noper   = NEXTOPER( cur );
3000
3001             U32 state        = 1;         /* required init */
3002
3003             U16 charid       = 0;         /* sanity init */
3004             U32 accept_state = 0;         /* sanity init */
3005
3006             U32 wordlen      = 0;         /* required init */
3007
3008             if (OP(noper) == NOTHING) {
3009                 regnode *noper_next= regnext(noper);
3010                 if (noper_next < tail)
3011                     noper= noper_next;
3012             }
3013
3014             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3015                 const U8 *uc= (U8*)STRING(noper);
3016                 const U8 *e= uc + STR_LEN(noper);
3017
3018                 for ( ; uc < e ; uc += len ) {
3019
3020                     TRIE_READ_CHAR;
3021
3022                     if ( uvc < 256 ) {
3023                         charid = trie->charmap[ uvc ];
3024                     } else {
3025                         SV* const * const svpp = hv_fetch( widecharmap,
3026                                                            (char*)&uvc,
3027                                                            sizeof( UV ),
3028                                                            0);
3029                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3030                     }
3031                     if ( charid ) {
3032                         charid--;
3033                         if ( !trie->trans[ state + charid ].next ) {
3034                             trie->trans[ state + charid ].next = next_alloc;
3035                             trie->trans[ state ].check++;
3036                             prev_states[TRIE_NODENUM(next_alloc)]
3037                                     = TRIE_NODENUM(state);
3038                             next_alloc += trie->uniquecharcount;
3039                         }
3040                         state = trie->trans[ state + charid ].next;
3041                     } else {
3042                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3043                     }
3044                     /* charid is now 0 if we dont know the char read, or
3045                      * nonzero if we do */
3046                 }
3047             }
3048             accept_state = TRIE_NODENUM( state );
3049             TRIE_HANDLE_WORD(accept_state);
3050
3051         } /* end second pass */
3052
3053         /* and now dump it out before we compress it */
3054         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3055                                                           revcharmap,
3056                                                           next_alloc, depth+1));
3057
3058         {
3059         /*
3060            * Inplace compress the table.*
3061
3062            For sparse data sets the table constructed by the trie algorithm will
3063            be mostly 0/FAIL transitions or to put it another way mostly empty.
3064            (Note that leaf nodes will not contain any transitions.)
3065
3066            This algorithm compresses the tables by eliminating most such
3067            transitions, at the cost of a modest bit of extra work during lookup:
3068
3069            - Each states[] entry contains a .base field which indicates the
3070            index in the state[] array wheres its transition data is stored.
3071
3072            - If .base is 0 there are no valid transitions from that node.
3073
3074            - If .base is nonzero then charid is added to it to find an entry in
3075            the trans array.
3076
3077            -If trans[states[state].base+charid].check!=state then the
3078            transition is taken to be a 0/Fail transition. Thus if there are fail
3079            transitions at the front of the node then the .base offset will point
3080            somewhere inside the previous nodes data (or maybe even into a node
3081            even earlier), but the .check field determines if the transition is
3082            valid.
3083
3084            XXX - wrong maybe?
3085            The following process inplace converts the table to the compressed
3086            table: We first do not compress the root node 1,and mark all its
3087            .check pointers as 1 and set its .base pointer as 1 as well. This
3088            allows us to do a DFA construction from the compressed table later,
3089            and ensures that any .base pointers we calculate later are greater
3090            than 0.
3091
3092            - We set 'pos' to indicate the first entry of the second node.
3093
3094            - We then iterate over the columns of the node, finding the first and
3095            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3096            and set the .check pointers accordingly, and advance pos
3097            appropriately and repreat for the next node. Note that when we copy
3098            the next pointers we have to convert them from the original
3099            NODEIDX form to NODENUM form as the former is not valid post
3100            compression.
3101
3102            - If a node has no transitions used we mark its base as 0 and do not
3103            advance the pos pointer.
3104
3105            - If a node only has one transition we use a second pointer into the
3106            structure to fill in allocated fail transitions from other states.
3107            This pointer is independent of the main pointer and scans forward
3108            looking for null transitions that are allocated to a state. When it
3109            finds one it writes the single transition into the "hole".  If the
3110            pointer doesnt find one the single transition is appended as normal.
3111
3112            - Once compressed we can Renew/realloc the structures to release the
3113            excess space.
3114
3115            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3116            specifically Fig 3.47 and the associated pseudocode.
3117
3118            demq
3119         */
3120         const U32 laststate = TRIE_NODENUM( next_alloc );
3121         U32 state, charid;
3122         U32 pos = 0, zp=0;
3123         trie->statecount = laststate;
3124
3125         for ( state = 1 ; state < laststate ; state++ ) {
3126             U8 flag = 0;
3127             const U32 stateidx = TRIE_NODEIDX( state );
3128             const U32 o_used = trie->trans[ stateidx ].check;
3129             U32 used = trie->trans[ stateidx ].check;
3130             trie->trans[ stateidx ].check = 0;
3131
3132             for ( charid = 0;
3133                   used && charid < trie->uniquecharcount;
3134                   charid++ )
3135             {
3136                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3137                     if ( trie->trans[ stateidx + charid ].next ) {
3138                         if (o_used == 1) {
3139                             for ( ; zp < pos ; zp++ ) {
3140                                 if ( ! trie->trans[ zp ].next ) {
3141                                     break;
3142                                 }
3143                             }
3144                             trie->states[ state ].trans.base
3145                                                     = zp
3146                                                       + trie->uniquecharcount
3147                                                       - charid ;
3148                             trie->trans[ zp ].next
3149                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3150                                                              + charid ].next );
3151                             trie->trans[ zp ].check = state;
3152                             if ( ++zp > pos ) pos = zp;
3153                             break;
3154                         }
3155                         used--;
3156                     }
3157                     if ( !flag ) {
3158                         flag = 1;
3159                         trie->states[ state ].trans.base
3160                                        = pos + trie->uniquecharcount - charid ;
3161                     }
3162                     trie->trans[ pos ].next
3163                         = SAFE_TRIE_NODENUM(
3164                                        trie->trans[ stateidx + charid ].next );
3165                     trie->trans[ pos ].check = state;
3166                     pos++;
3167                 }
3168             }
3169         }
3170         trie->lasttrans = pos + 1;
3171         trie->states = (reg_trie_state *)
3172             PerlMemShared_realloc( trie->states, laststate
3173                                    * sizeof(reg_trie_state) );
3174         DEBUG_TRIE_COMPILE_MORE_r(
3175             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3176                 depth+1,
3177                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3178                        + 1 ),
3179                 (IV)next_alloc,
3180                 (IV)pos,
3181                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3182             );
3183
3184         } /* end table compress */
3185     }
3186     DEBUG_TRIE_COMPILE_MORE_r(
3187             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3188                 depth+1,
3189                 (UV)trie->statecount,
3190                 (UV)trie->lasttrans)
3191     );
3192     /* resize the trans array to remove unused space */
3193     trie->trans = (reg_trie_trans *)
3194         PerlMemShared_realloc( trie->trans, trie->lasttrans
3195                                * sizeof(reg_trie_trans) );
3196
3197     {   /* Modify the program and insert the new TRIE node */
3198         U8 nodetype =(U8)(flags & 0xFF);
3199         char *str=NULL;
3200
3201 #ifdef DEBUGGING
3202         regnode *optimize = NULL;
3203 #ifdef RE_TRACK_PATTERN_OFFSETS
3204
3205         U32 mjd_offset = 0;
3206         U32 mjd_nodelen = 0;
3207 #endif /* RE_TRACK_PATTERN_OFFSETS */
3208 #endif /* DEBUGGING */
3209         /*
3210            This means we convert either the first branch or the first Exact,
3211            depending on whether the thing following (in 'last') is a branch
3212            or not and whther first is the startbranch (ie is it a sub part of
3213            the alternation or is it the whole thing.)
3214            Assuming its a sub part we convert the EXACT otherwise we convert
3215            the whole branch sequence, including the first.
3216          */
3217         /* Find the node we are going to overwrite */
3218         if ( first != startbranch || OP( last ) == BRANCH ) {
3219             /* branch sub-chain */
3220             NEXT_OFF( first ) = (U16)(last - first);
3221 #ifdef RE_TRACK_PATTERN_OFFSETS
3222             DEBUG_r({
3223                 mjd_offset= Node_Offset((convert));
3224                 mjd_nodelen= Node_Length((convert));
3225             });
3226 #endif
3227             /* whole branch chain */
3228         }
3229 #ifdef RE_TRACK_PATTERN_OFFSETS
3230         else {
3231             DEBUG_r({
3232                 const  regnode *nop = NEXTOPER( convert );
3233                 mjd_offset= Node_Offset((nop));
3234                 mjd_nodelen= Node_Length((nop));
3235             });
3236         }
3237         DEBUG_OPTIMISE_r(
3238             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3239                 depth+1,
3240                 (UV)mjd_offset, (UV)mjd_nodelen)
3241         );
3242 #endif
3243         /* But first we check to see if there is a common prefix we can
3244            split out as an EXACT and put in front of the TRIE node.  */
3245         trie->startstate= 1;
3246         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3247             /* we want to find the first state that has more than
3248              * one transition, if that state is not the first state
3249              * then we have a common prefix which we can remove.
3250              */
3251             U32 state;
3252             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3253                 U32 ofs = 0;
3254                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3255                                        transition, -1 means none */
3256                 U32 count = 0;
3257                 const U32 base = trie->states[ state ].trans.base;
3258
3259                 /* does this state terminate an alternation? */
3260                 if ( trie->states[state].wordnum )
3261                         count = 1;
3262
3263                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3264                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3265                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3266                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3267                     {
3268                         if ( ++count > 1 ) {
3269                             /* we have more than one transition */
3270                             SV **tmp;
3271                             U8 *ch;
3272                             /* if this is the first state there is no common prefix
3273                              * to extract, so we can exit */
3274                             if ( state == 1 ) break;
3275                             tmp = av_fetch( revcharmap, ofs, 0);
3276                             ch = (U8*)SvPV_nolen_const( *tmp );
3277
3278                             /* if we are on count 2 then we need to initialize the
3279                              * bitmap, and store the previous char if there was one
3280                              * in it*/
3281                             if ( count == 2 ) {
3282                                 /* clear the bitmap */
3283                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3284                                 DEBUG_OPTIMISE_r(
3285                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3286                                         depth+1,
3287                                         (UV)state));
3288                                 if (first_ofs >= 0) {
3289                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3290                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3291
3292                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3293                                     DEBUG_OPTIMISE_r(
3294                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3295                                     );
3296                                 }
3297                             }
3298                             /* store the current firstchar in the bitmap */
3299                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3300                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3301                         }
3302                         first_ofs = ofs;
3303                     }
3304                 }
3305                 if ( count == 1 ) {
3306                     /* This state has only one transition, its transition is part
3307                      * of a common prefix - we need to concatenate the char it
3308                      * represents to what we have so far. */
3309                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3310                     STRLEN len;
3311                     char *ch = SvPV( *tmp, len );
3312                     DEBUG_OPTIMISE_r({
3313                         SV *sv=sv_newmortal();
3314                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3315                             depth+1,
3316                             (UV)state, (UV)first_ofs,
3317                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3318                                 PL_colors[0], PL_colors[1],
3319                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3320                                 PERL_PV_ESCAPE_FIRSTCHAR
3321                             )
3322                         );
3323                     });
3324                     if ( state==1 ) {
3325                         OP( convert ) = nodetype;
3326                         str=STRING(convert);
3327                         STR_LEN(convert)=0;
3328                     }
3329                     STR_LEN(convert) += len;
3330                     while (len--)
3331                         *str++ = *ch++;
3332                 } else {
3333 #ifdef DEBUGGING
3334                     if (state>1)
3335                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3336 #endif
3337                     break;
3338                 }
3339             }
3340             trie->prefixlen = (state-1);
3341             if (str) {
3342                 regnode *n = convert+NODE_SZ_STR(convert);
3343                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3344                 trie->startstate = state;
3345                 trie->minlen -= (state - 1);
3346                 trie->maxlen -= (state - 1);
3347 #ifdef DEBUGGING
3348                /* At least the UNICOS C compiler choked on this
3349                 * being argument to DEBUG_r(), so let's just have
3350                 * it right here. */
3351                if (
3352 #ifdef PERL_EXT_RE_BUILD
3353                    1
3354 #else
3355                    DEBUG_r_TEST
3356 #endif
3357                    ) {
3358                    regnode *fix = convert;
3359                    U32 word = trie->wordcount;
3360                    mjd_nodelen++;
3361                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3362                    while( ++fix < n ) {
3363                        Set_Node_Offset_Length(fix, 0, 0);
3364                    }
3365                    while (word--) {
3366                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3367                        if (tmp) {
3368                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3369                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3370                            else
3371                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3372                        }
3373                    }
3374                }
3375 #endif
3376                 if (trie->maxlen) {
3377                     convert = n;
3378                 } else {
3379                     NEXT_OFF(convert) = (U16)(tail - convert);
3380                     DEBUG_r(optimize= n);
3381                 }
3382             }
3383         }
3384         if (!jumper)
3385             jumper = last;
3386         if ( trie->maxlen ) {
3387             NEXT_OFF( convert ) = (U16)(tail - convert);
3388             ARG_SET( convert, data_slot );
3389             /* Store the offset to the first unabsorbed branch in
3390                jump[0], which is otherwise unused by the jump logic.
3391                We use this when dumping a trie and during optimisation. */
3392             if (trie->jump)
3393                 trie->jump[0] = (U16)(nextbranch - convert);
3394
3395             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3396              *   and there is a bitmap
3397              *   and the first "jump target" node we found leaves enough room
3398              * then convert the TRIE node into a TRIEC node, with the bitmap
3399              * embedded inline in the opcode - this is hypothetically faster.
3400              */
3401             if ( !trie->states[trie->startstate].wordnum
3402                  && trie->bitmap
3403                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3404             {
3405                 OP( convert ) = TRIEC;
3406                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3407                 PerlMemShared_free(trie->bitmap);
3408                 trie->bitmap= NULL;
3409             } else
3410                 OP( convert ) = TRIE;
3411
3412             /* store the type in the flags */
3413             convert->flags = nodetype;
3414             DEBUG_r({
3415             optimize = convert
3416                       + NODE_STEP_REGNODE
3417                       + regarglen[ OP( convert ) ];
3418             });
3419             /* XXX We really should free up the resource in trie now,
3420                    as we won't use them - (which resources?) dmq */
3421         }
3422         /* needed for dumping*/
3423         DEBUG_r(if (optimize) {
3424             regnode *opt = convert;
3425
3426             while ( ++opt < optimize) {
3427                 Set_Node_Offset_Length(opt,0,0);
3428             }
3429             /*
3430                 Try to clean up some of the debris left after the
3431                 optimisation.
3432              */
3433             while( optimize < jumper ) {
3434                 mjd_nodelen += Node_Length((optimize));
3435                 OP( optimize ) = OPTIMIZED;
3436                 Set_Node_Offset_Length(optimize,0,0);
3437                 optimize++;
3438             }
3439             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3440         });
3441     } /* end node insert */
3442
3443     /*  Finish populating the prev field of the wordinfo array.  Walk back
3444      *  from each accept state until we find another accept state, and if
3445      *  so, point the first word's .prev field at the second word. If the
3446      *  second already has a .prev field set, stop now. This will be the
3447      *  case either if we've already processed that word's accept state,
3448      *  or that state had multiple words, and the overspill words were
3449      *  already linked up earlier.
3450      */
3451     {
3452         U16 word;
3453         U32 state;
3454         U16 prev;
3455
3456         for (word=1; word <= trie->wordcount; word++) {
3457             prev = 0;
3458             if (trie->wordinfo[word].prev)
3459                 continue;
3460             state = trie->wordinfo[word].accept;
3461             while (state) {
3462                 state = prev_states[state];
3463                 if (!state)
3464                     break;
3465                 prev = trie->states[state].wordnum;
3466                 if (prev)
3467                     break;
3468             }
3469             trie->wordinfo[word].prev = prev;
3470         }
3471         Safefree(prev_states);
3472     }
3473
3474
3475     /* and now dump out the compressed format */
3476     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3477
3478     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3479 #ifdef DEBUGGING
3480     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3481     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3482 #else
3483     SvREFCNT_dec_NN(revcharmap);
3484 #endif
3485     return trie->jump
3486            ? MADE_JUMP_TRIE
3487            : trie->startstate>1
3488              ? MADE_EXACT_TRIE
3489              : MADE_TRIE;
3490 }
3491
3492 STATIC regnode *
3493 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3494 {
3495 /* The Trie is constructed and compressed now so we can build a fail array if
3496  * it's needed
3497
3498    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3499    3.32 in the
3500    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3501    Ullman 1985/88
3502    ISBN 0-201-10088-6
3503
3504    We find the fail state for each state in the trie, this state is the longest
3505    proper suffix of the current state's 'word' that is also a proper prefix of
3506    another word in our trie. State 1 represents the word '' and is thus the
3507    default fail state. This allows the DFA not to have to restart after its
3508    tried and failed a word at a given point, it simply continues as though it
3509    had been matching the other word in the first place.
3510    Consider
3511       'abcdgu'=~/abcdefg|cdgu/
3512    When we get to 'd' we are still matching the first word, we would encounter
3513    'g' which would fail, which would bring us to the state representing 'd' in
3514    the second word where we would try 'g' and succeed, proceeding to match
3515    'cdgu'.
3516  */
3517  /* add a fail transition */
3518     const U32 trie_offset = ARG(source);
3519     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3520     U32 *q;
3521     const U32 ucharcount = trie->uniquecharcount;
3522     const U32 numstates = trie->statecount;
3523     const U32 ubound = trie->lasttrans + ucharcount;
3524     U32 q_read = 0;
3525     U32 q_write = 0;
3526     U32 charid;
3527     U32 base = trie->states[ 1 ].trans.base;
3528     U32 *fail;
3529     reg_ac_data *aho;
3530     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3531     regnode *stclass;
3532     GET_RE_DEBUG_FLAGS_DECL;
3533
3534     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3535     PERL_UNUSED_CONTEXT;
3536 #ifndef DEBUGGING
3537     PERL_UNUSED_ARG(depth);
3538 #endif
3539
3540     if ( OP(source) == TRIE ) {
3541         struct regnode_1 *op = (struct regnode_1 *)
3542             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3543         StructCopy(source,op,struct regnode_1);
3544         stclass = (regnode *)op;
3545     } else {
3546         struct regnode_charclass *op = (struct regnode_charclass *)
3547             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3548         StructCopy(source,op,struct regnode_charclass);
3549         stclass = (regnode *)op;
3550     }
3551     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3552
3553     ARG_SET( stclass, data_slot );
3554     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3555     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3556     aho->trie=trie_offset;
3557     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3558     Copy( trie->states, aho->states, numstates, reg_trie_state );
3559     Newxz( q, numstates, U32);
3560     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3561     aho->refcount = 1;
3562     fail = aho->fail;
3563     /* initialize fail[0..1] to be 1 so that we always have
3564        a valid final fail state */
3565     fail[ 0 ] = fail[ 1 ] = 1;
3566
3567     for ( charid = 0; charid < ucharcount ; charid++ ) {
3568         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3569         if ( newstate ) {
3570             q[ q_write ] = newstate;
3571             /* set to point at the root */
3572             fail[ q[ q_write++ ] ]=1;
3573         }
3574     }
3575     while ( q_read < q_write) {
3576         const U32 cur = q[ q_read++ % numstates ];
3577         base = trie->states[ cur ].trans.base;
3578
3579         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3580             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3581             if (ch_state) {
3582                 U32 fail_state = cur;
3583                 U32 fail_base;
3584                 do {
3585                     fail_state = fail[ fail_state ];
3586                     fail_base = aho->states[ fail_state ].trans.base;
3587                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3588
3589                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3590                 fail[ ch_state ] = fail_state;
3591                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3592                 {
3593                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3594                 }
3595                 q[ q_write++ % numstates] = ch_state;
3596             }
3597         }
3598     }
3599     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3600        when we fail in state 1, this allows us to use the
3601        charclass scan to find a valid start char. This is based on the principle
3602        that theres a good chance the string being searched contains lots of stuff
3603        that cant be a start char.
3604      */
3605     fail[ 0 ] = fail[ 1 ] = 0;
3606     DEBUG_TRIE_COMPILE_r({
3607         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3608                       depth, (UV)numstates
3609         );
3610         for( q_read=1; q_read<numstates; q_read++ ) {
3611             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3612         }
3613         Perl_re_printf( aTHX_  "\n");
3614     });
3615     Safefree(q);
3616     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3617     return stclass;
3618 }
3619
3620
3621 #define DEBUG_PEEP(str,scan,depth)         \
3622     DEBUG_OPTIMISE_r({if (scan){           \
3623        regnode *Next = regnext(scan);      \
3624        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);\
3625        Perl_re_indentf( aTHX_  "" str ">%3d: %s (%d)", \
3626            depth, REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3627            Next ? (REG_NODE_NUM(Next)) : 0 );\
3628        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3629        Perl_re_printf( aTHX_  "\n");                   \
3630    }});
3631
3632 /* The below joins as many adjacent EXACTish nodes as possible into a single
3633  * one.  The regop may be changed if the node(s) contain certain sequences that
3634  * require special handling.  The joining is only done if:
3635  * 1) there is room in the current conglomerated node to entirely contain the
3636  *    next one.
3637  * 2) they are the exact same node type
3638  *
3639  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3640  * these get optimized out
3641  *
3642  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3643  * as possible, even if that means splitting an existing node so that its first
3644  * part is moved to the preceeding node.  This would maximise the efficiency of
3645  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3646  * EXACTFish nodes into portions that don't change under folding vs those that
3647  * do.  Those portions that don't change may be the only things in the pattern that
3648  * could be used to find fixed and floating strings.
3649  *
3650  * If a node is to match under /i (folded), the number of characters it matches
3651  * can be different than its character length if it contains a multi-character
3652  * fold.  *min_subtract is set to the total delta number of characters of the
3653  * input nodes.
3654  *
3655  * And *unfolded_multi_char is set to indicate whether or not the node contains
3656  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3657  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3658  * SMALL LETTER SHARP S, as only if the target string being matched against
3659  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3660  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3661  * whose components are all above the Latin1 range are not run-time locale
3662  * dependent, and have already been folded by the time this function is
3663  * called.)
3664  *
3665  * This is as good a place as any to discuss the design of handling these
3666  * multi-character fold sequences.  It's been wrong in Perl for a very long
3667  * time.  There are three code points in Unicode whose multi-character folds
3668  * were long ago discovered to mess things up.  The previous designs for
3669  * dealing with these involved assigning a special node for them.  This
3670  * approach doesn't always work, as evidenced by this example:
3671  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3672  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3673  * would match just the \xDF, it won't be able to handle the case where a
3674  * successful match would have to cross the node's boundary.  The new approach
3675  * that hopefully generally solves the problem generates an EXACTFU_SS node
3676  * that is "sss" in this case.
3677  *
3678  * It turns out that there are problems with all multi-character folds, and not
3679  * just these three.  Now the code is general, for all such cases.  The
3680  * approach taken is:
3681  * 1)   This routine examines each EXACTFish node that could contain multi-
3682  *      character folded sequences.  Since a single character can fold into
3683  *      such a sequence, the minimum match length for this node is less than
3684  *      the number of characters in the node.  This routine returns in
3685  *      *min_subtract how many characters to subtract from the the actual
3686  *      length of the string to get a real minimum match length; it is 0 if
3687  *      there are no multi-char foldeds.  This delta is used by the caller to
3688  *      adjust the min length of the match, and the delta between min and max,
3689  *      so that the optimizer doesn't reject these possibilities based on size
3690  *      constraints.
3691  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3692  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3693  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3694  *      there is a possible fold length change.  That means that a regular
3695  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3696  *      with length changes, and so can be processed faster.  regexec.c takes
3697  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3698  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3699  *      known until runtime).  This saves effort in regex matching.  However,
3700  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3701  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3702  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3703  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3704  *      possibilities for the non-UTF8 patterns are quite simple, except for
3705  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3706  *      members of a fold-pair, and arrays are set up for all of them so that
3707  *      the other member of the pair can be found quickly.  Code elsewhere in
3708  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3709  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3710  *      described in the next item.
3711  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3712  *      validity of the fold won't be known until runtime, and so must remain
3713  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3714  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3715  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3716  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3717  *      The reason this is a problem is that the optimizer part of regexec.c
3718  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3719  *      that a character in the pattern corresponds to at most a single
3720  *      character in the target string.  (And I do mean character, and not byte
3721  *      here, unlike other parts of the documentation that have never been
3722  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3723  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3724  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3725  *      nodes, violate the assumption, and they are the only instances where it
3726  *      is violated.  I'm reluctant to try to change the assumption, as the
3727  *      code involved is impenetrable to me (khw), so instead the code here
3728  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3729  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3730  *      boolean indicating whether or not the node contains such a fold.  When
3731  *      it is true, the caller sets a flag that later causes the optimizer in
3732  *      this file to not set values for the floating and fixed string lengths,
3733  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3734  *      assumption.  Thus, there is no optimization based on string lengths for
3735  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3736  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3737  *      assumption is wrong only in these cases is that all other non-UTF-8
3738  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3739  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3740  *      EXACTF nodes because we don't know at compile time if it actually
3741  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3742  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3743  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3744  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3745  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3746  *      string would require the pattern to be forced into UTF-8, the overhead
3747  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3748  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3749  *      locale.)
3750  *
3751  *      Similarly, the code that generates tries doesn't currently handle
3752  *      not-already-folded multi-char folds, and it looks like a pain to change
3753  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3754  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3755  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3756  *      using /iaa matching will be doing so almost entirely with ASCII
3757  *      strings, so this should rarely be encountered in practice */
3758
3759 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3760     if (PL_regkind[OP(scan)] == EXACT) \
3761         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3762
3763 STATIC U32
3764 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3765                    UV *min_subtract, bool *unfolded_multi_char,
3766                    U32 flags,regnode *val, U32 depth)
3767 {
3768     /* Merge several consecutive EXACTish nodes into one. */
3769     regnode *n = regnext(scan);
3770     U32 stringok = 1;
3771     regnode *next = scan + NODE_SZ_STR(scan);
3772     U32 merged = 0;
3773     U32 stopnow = 0;
3774 #ifdef DEBUGGING
3775     regnode *stop = scan;
3776     GET_RE_DEBUG_FLAGS_DECL;
3777 #else
3778     PERL_UNUSED_ARG(depth);
3779 #endif
3780
3781     PERL_ARGS_ASSERT_JOIN_EXACT;
3782 #ifndef EXPERIMENTAL_INPLACESCAN
3783     PERL_UNUSED_ARG(flags);
3784     PERL_UNUSED_ARG(val);
3785 #endif
3786     DEBUG_PEEP("join",scan,depth);
3787
3788     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3789      * EXACT ones that are mergeable to the current one. */
3790     while (n
3791            && (PL_regkind[OP(n)] == NOTHING
3792                || (stringok && OP(n) == OP(scan)))
3793            && NEXT_OFF(n)
3794            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3795     {
3796
3797         if (OP(n) == TAIL || n > next)
3798             stringok = 0;
3799         if (PL_regkind[OP(n)] == NOTHING) {
3800             DEBUG_PEEP("skip:",n,depth);
3801             NEXT_OFF(scan) += NEXT_OFF(n);
3802             next = n + NODE_STEP_REGNODE;
3803 #ifdef DEBUGGING
3804             if (stringok)
3805                 stop = n;
3806 #endif
3807             n = regnext(n);
3808         }
3809         else if (stringok) {
3810             const unsigned int oldl = STR_LEN(scan);
3811             regnode * const nnext = regnext(n);
3812
3813             /* XXX I (khw) kind of doubt that this works on platforms (should
3814              * Perl ever run on one) where U8_MAX is above 255 because of lots
3815              * of other assumptions */
3816             /* Don't join if the sum can't fit into a single node */
3817             if (oldl + STR_LEN(n) > U8_MAX)
3818                 break;
3819
3820             DEBUG_PEEP("merg",n,depth);
3821             merged++;
3822
3823             NEXT_OFF(scan) += NEXT_OFF(n);
3824             STR_LEN(scan) += STR_LEN(n);
3825             next = n + NODE_SZ_STR(n);
3826             /* Now we can overwrite *n : */
3827             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3828 #ifdef DEBUGGING
3829             stop = next - 1;
3830 #endif
3831             n = nnext;
3832             if (stopnow) break;
3833         }
3834
3835 #ifdef EXPERIMENTAL_INPLACESCAN
3836         if (flags && !NEXT_OFF(n)) {
3837             DEBUG_PEEP("atch", val, depth);
3838             if (reg_off_by_arg[OP(n)]) {
3839                 ARG_SET(n, val - n);
3840             }
3841             else {
3842                 NEXT_OFF(n) = val - n;
3843             }
3844             stopnow = 1;
3845         }
3846 #endif
3847     }
3848
3849     *min_subtract = 0;
3850     *unfolded_multi_char = FALSE;
3851
3852     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3853      * can now analyze for sequences of problematic code points.  (Prior to
3854      * this final joining, sequences could have been split over boundaries, and
3855      * hence missed).  The sequences only happen in folding, hence for any
3856      * non-EXACT EXACTish node */
3857     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3858         U8* s0 = (U8*) STRING(scan);
3859         U8* s = s0;
3860         U8* s_end = s0 + STR_LEN(scan);
3861
3862         int total_count_delta = 0;  /* Total delta number of characters that
3863                                        multi-char folds expand to */
3864
3865         /* One pass is made over the node's string looking for all the
3866          * possibilities.  To avoid some tests in the loop, there are two main
3867          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3868          * non-UTF-8 */
3869         if (UTF) {
3870             U8* folded = NULL;
3871
3872             if (OP(scan) == EXACTFL) {
3873                 U8 *d;
3874
3875                 /* An EXACTFL node would already have been changed to another
3876                  * node type unless there is at least one character in it that
3877                  * is problematic; likely a character whose fold definition
3878                  * won't be known until runtime, and so has yet to be folded.
3879                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3880                  * to handle the UTF-8 case, we need to create a temporary
3881                  * folded copy using UTF-8 locale rules in order to analyze it.
3882                  * This is because our macros that look to see if a sequence is
3883                  * a multi-char fold assume everything is folded (otherwise the
3884                  * tests in those macros would be too complicated and slow).
3885                  * Note that here, the non-problematic folds will have already
3886                  * been done, so we can just copy such characters.  We actually
3887                  * don't completely fold the EXACTFL string.  We skip the
3888                  * unfolded multi-char folds, as that would just create work
3889                  * below to figure out the size they already are */
3890
3891                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3892                 d = folded;
3893                 while (s < s_end) {
3894                     STRLEN s_len = UTF8SKIP(s);
3895                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3896                         Copy(s, d, s_len, U8);
3897                         d += s_len;
3898                     }
3899                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3900                         *unfolded_multi_char = TRUE;
3901                         Copy(s, d, s_len, U8);
3902                         d += s_len;
3903                     }
3904                     else if (isASCII(*s)) {
3905                         *(d++) = toFOLD(*s);
3906                     }
3907                     else {
3908                         STRLEN len;
3909                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
3910                         d += len;
3911                     }
3912                     s += s_len;
3913                 }
3914
3915                 /* Point the remainder of the routine to look at our temporary
3916                  * folded copy */
3917                 s = folded;
3918                 s_end = d;
3919             } /* End of creating folded copy of EXACTFL string */
3920
3921             /* Examine the string for a multi-character fold sequence.  UTF-8
3922              * patterns have all characters pre-folded by the time this code is
3923              * executed */
3924             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3925                                      length sequence we are looking for is 2 */
3926             {
3927                 int count = 0;  /* How many characters in a multi-char fold */
3928                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3929                 if (! len) {    /* Not a multi-char fold: get next char */
3930                     s += UTF8SKIP(s);
3931                     continue;
3932                 }
3933
3934                 /* Nodes with 'ss' require special handling, except for
3935                  * EXACTFA-ish for which there is no multi-char fold to this */
3936                 if (len == 2 && *s == 's' && *(s+1) == 's'
3937                     && OP(scan) != EXACTFA
3938                     && OP(scan) != EXACTFA_NO_TRIE)
3939                 {
3940                     count = 2;
3941                     if (OP(scan) != EXACTFL) {
3942                         OP(scan) = EXACTFU_SS;
3943                     }
3944                     s += 2;
3945                 }
3946                 else { /* Here is a generic multi-char fold. */
3947                     U8* multi_end  = s + len;
3948
3949                     /* Count how many characters are in it.  In the case of
3950                      * /aa, no folds which contain ASCII code points are
3951                      * allowed, so check for those, and skip if found. */
3952                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3953                         count = utf8_length(s, multi_end);
3954                         s = multi_end;
3955                     }
3956                     else {
3957                         while (s < multi_end) {
3958                             if (isASCII(*s)) {
3959                                 s++;
3960                                 goto next_iteration;
3961                             }
3962                             else {
3963                                 s += UTF8SKIP(s);
3964                             }
3965                             count++;
3966                         }
3967                     }
3968                 }
3969
3970                 /* The delta is how long the sequence is minus 1 (1 is how long
3971                  * the character that folds to the sequence is) */
3972                 total_count_delta += count - 1;
3973               next_iteration: ;
3974             }
3975
3976             /* We created a temporary folded copy of the string in EXACTFL
3977              * nodes.  Therefore we need to be sure it doesn't go below zero,
3978              * as the real string could be shorter */
3979             if (OP(scan) == EXACTFL) {
3980                 int total_chars = utf8_length((U8*) STRING(scan),
3981                                            (U8*) STRING(scan) + STR_LEN(scan));
3982                 if (total_count_delta > total_chars) {
3983                     total_count_delta = total_chars;
3984                 }
3985             }
3986
3987             *min_subtract += total_count_delta;
3988             Safefree(folded);
3989         }
3990         else if (OP(scan) == EXACTFA) {
3991
3992             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3993              * fold to the ASCII range (and there are no existing ones in the
3994              * upper latin1 range).  But, as outlined in the comments preceding
3995              * this function, we need to flag any occurrences of the sharp s.
3996              * This character forbids trie formation (because of added
3997              * complexity) */
3998 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
3999    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4000                                       || UNICODE_DOT_DOT_VERSION > 0)
4001             while (s < s_end) {
4002                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4003                     OP(scan) = EXACTFA_NO_TRIE;
4004                     *unfolded_multi_char = TRUE;
4005                     break;
4006                 }
4007                 s++;
4008             }
4009         }
4010         else {
4011
4012             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
4013              * folds that are all Latin1.  As explained in the comments
4014              * preceding this function, we look also for the sharp s in EXACTF
4015              * and EXACTFL nodes; it can be in the final position.  Otherwise
4016              * we can stop looking 1 byte earlier because have to find at least
4017              * two characters for a multi-fold */
4018             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4019                               ? s_end
4020                               : s_end -1;
4021
4022             while (s < upper) {
4023                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4024                 if (! len) {    /* Not a multi-char fold. */
4025                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4026                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4027                     {
4028                         *unfolded_multi_char = TRUE;
4029                     }
4030                     s++;
4031                     continue;
4032                 }
4033
4034                 if (len == 2
4035                     && isALPHA_FOLD_EQ(*s, 's')
4036                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4037                 {
4038
4039                     /* EXACTF nodes need to know that the minimum length
4040                      * changed so that a sharp s in the string can match this
4041                      * ss in the pattern, but they remain EXACTF nodes, as they
4042                      * won't match this unless the target string is is UTF-8,
4043                      * which we don't know until runtime.  EXACTFL nodes can't
4044                      * transform into EXACTFU nodes */
4045                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4046                         OP(scan) = EXACTFU_SS;
4047                     }
4048                 }
4049
4050                 *min_subtract += len - 1;
4051                 s += len;
4052             }
4053 #endif
4054         }
4055     }
4056
4057 #ifdef DEBUGGING
4058     /* Allow dumping but overwriting the collection of skipped
4059      * ops and/or strings with fake optimized ops */
4060     n = scan + NODE_SZ_STR(scan);
4061     while (n <= stop) {
4062         OP(n) = OPTIMIZED;
4063         FLAGS(n) = 0;
4064         NEXT_OFF(n) = 0;
4065         n++;
4066     }
4067 #endif
4068     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
4069     return stopnow;
4070 }
4071
4072 /* REx optimizer.  Converts nodes into quicker variants "in place".
4073    Finds fixed substrings.  */
4074
4075 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4076    to the position after last scanned or to NULL. */
4077
4078 #define INIT_AND_WITHP \
4079     assert(!and_withp); \
4080     Newx(and_withp,1, regnode_ssc); \
4081     SAVEFREEPV(and_withp)
4082
4083
4084 static void
4085 S_unwind_scan_frames(pTHX_ const void *p)
4086 {
4087     scan_frame *f= (scan_frame *)p;
4088     do {
4089         scan_frame *n= f->next_frame;
4090         Safefree(f);
4091         f= n;
4092     } while (f);
4093 }
4094
4095
4096 STATIC SSize_t
4097 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4098                         SSize_t *minlenp, SSize_t *deltap,
4099                         regnode *last,
4100                         scan_data_t *data,
4101                         I32 stopparen,
4102                         U32 recursed_depth,
4103                         regnode_ssc *and_withp,
4104                         U32 flags, U32 depth)
4105                         /* scanp: Start here (read-write). */
4106                         /* deltap: Write maxlen-minlen here. */
4107                         /* last: Stop before this one. */
4108                         /* data: string data about the pattern */
4109                         /* stopparen: treat close N as END */
4110                         /* recursed: which subroutines have we recursed into */
4111                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4112 {
4113     /* There must be at least this number of characters to match */
4114     SSize_t min = 0;
4115     I32 pars = 0, code;
4116     regnode *scan = *scanp, *next;
4117     SSize_t delta = 0;
4118     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4119     int is_inf_internal = 0;            /* The studied chunk is infinite */
4120     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4121     scan_data_t data_fake;
4122     SV *re_trie_maxbuff = NULL;
4123     regnode *first_non_open = scan;
4124     SSize_t stopmin = SSize_t_MAX;
4125     scan_frame *frame = NULL;
4126     GET_RE_DEBUG_FLAGS_DECL;
4127
4128     PERL_ARGS_ASSERT_STUDY_CHUNK;
4129     RExC_study_started= 1;
4130
4131
4132     if ( depth == 0 ) {
4133         while (first_non_open && OP(first_non_open) == OPEN)
4134             first_non_open=regnext(first_non_open);
4135     }
4136
4137
4138   fake_study_recurse:
4139     DEBUG_r(
4140         RExC_study_chunk_recursed_count++;
4141     );
4142     DEBUG_OPTIMISE_MORE_r(
4143     {
4144         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4145             depth, (long)stopparen,
4146             (unsigned long)RExC_study_chunk_recursed_count,
4147             (unsigned long)depth, (unsigned long)recursed_depth,
4148             scan,
4149             last);
4150         if (recursed_depth) {
4151             U32 i;
4152             U32 j;
4153             for ( j = 0 ; j < recursed_depth ; j++ ) {
4154                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4155                     if (
4156                         PAREN_TEST(RExC_study_chunk_recursed +
4157                                    ( j * RExC_study_chunk_recursed_bytes), i )
4158                         && (
4159                             !j ||
4160                             !PAREN_TEST(RExC_study_chunk_recursed +
4161                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4162                         )
4163                     ) {
4164                         Perl_re_printf( aTHX_ " %d",(int)i);
4165                         break;
4166                     }
4167                 }
4168                 if ( j + 1 < recursed_depth ) {
4169                     Perl_re_printf( aTHX_  ",");
4170                 }
4171             }
4172         }
4173         Perl_re_printf( aTHX_ "\n");
4174     }
4175     );
4176     while ( scan && OP(scan) != END && scan < last ){
4177         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4178                                    node length to get a real minimum (because
4179                                    the folded version may be shorter) */
4180         bool unfolded_multi_char = FALSE;
4181         /* Peephole optimizer: */
4182         DEBUG_STUDYDATA("Peep:", data, depth);
4183         DEBUG_PEEP("Peep", scan, depth);
4184
4185
4186         /* The reason we do this here is that we need to deal with things like
4187          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4188          * parsing code, as each (?:..) is handled by a different invocation of
4189          * reg() -- Yves
4190          */
4191         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4192
4193         /* Follow the next-chain of the current node and optimize
4194            away all the NOTHINGs from it.  */
4195         if (OP(scan) != CURLYX) {
4196             const int max = (reg_off_by_arg[OP(scan)]
4197                        ? I32_MAX
4198                        /* I32 may be smaller than U16 on CRAYs! */
4199                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4200             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4201             int noff;
4202             regnode *n = scan;
4203
4204             /* Skip NOTHING and LONGJMP. */
4205             while ((n = regnext(n))
4206                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4207                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4208                    && off + noff < max)
4209                 off += noff;
4210             if (reg_off_by_arg[OP(scan)])
4211                 ARG(scan) = off;
4212             else
4213                 NEXT_OFF(scan) = off;
4214         }
4215
4216         /* The principal pseudo-switch.  Cannot be a switch, since we
4217            look into several different things.  */
4218         if ( OP(scan) == DEFINEP ) {
4219             SSize_t minlen = 0;
4220             SSize_t deltanext = 0;
4221             SSize_t fake_last_close = 0;
4222             I32 f = SCF_IN_DEFINE;
4223
4224             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4225             scan = regnext(scan);
4226             assert( OP(scan) == IFTHEN );
4227             DEBUG_PEEP("expect IFTHEN", scan, depth);
4228
4229             data_fake.last_closep= &fake_last_close;
4230             minlen = *minlenp;
4231             next = regnext(scan);
4232             scan = NEXTOPER(NEXTOPER(scan));
4233             DEBUG_PEEP("scan", scan, depth);
4234             DEBUG_PEEP("next", next, depth);
4235
4236             /* we suppose the run is continuous, last=next...
4237              * NOTE we dont use the return here! */
4238             (void)study_chunk(pRExC_state, &scan, &minlen,
4239                               &deltanext, next, &data_fake, stopparen,
4240                               recursed_depth, NULL, f, depth+1);
4241
4242             scan = next;
4243         } else
4244         if (
4245             OP(scan) == BRANCH  ||
4246             OP(scan) == BRANCHJ ||
4247             OP(scan) == IFTHEN
4248         ) {
4249             next = regnext(scan);
4250             code = OP(scan);
4251
4252             /* The op(next)==code check below is to see if we
4253              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4254              * IFTHEN is special as it might not appear in pairs.
4255              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4256              * we dont handle it cleanly. */
4257             if (OP(next) == code || code == IFTHEN) {
4258                 /* NOTE - There is similar code to this block below for
4259                  * handling TRIE nodes on a re-study.  If you change stuff here
4260                  * check there too. */
4261                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4262                 regnode_ssc accum;
4263                 regnode * const startbranch=scan;
4264
4265                 if (flags & SCF_DO_SUBSTR) {
4266                     /* Cannot merge strings after this. */
4267                     scan_commit(pRExC_state, data, minlenp, is_inf);
4268                 }
4269
4270                 if (flags & SCF_DO_STCLASS)
4271                     ssc_init_zero(pRExC_state, &accum);
4272
4273                 while (OP(scan) == code) {
4274                     SSize_t deltanext, minnext, fake;
4275                     I32 f = 0;
4276                     regnode_ssc this_class;
4277
4278                     DEBUG_PEEP("Branch", scan, depth);
4279
4280                     num++;
4281                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4282                     if (data) {
4283                         data_fake.whilem_c = data->whilem_c;
4284                         data_fake.last_closep = data->last_closep;
4285                     }
4286                     else
4287                         data_fake.last_closep = &fake;
4288
4289                     data_fake.pos_delta = delta;
4290                     next = regnext(scan);
4291
4292                     scan = NEXTOPER(scan); /* everything */
4293                     if (code != BRANCH)    /* everything but BRANCH */
4294                         scan = NEXTOPER(scan);
4295
4296                     if (flags & SCF_DO_STCLASS) {
4297                         ssc_init(pRExC_state, &this_class);
4298                         data_fake.start_class = &this_class;
4299                         f = SCF_DO_STCLASS_AND;
4300                     }
4301                     if (flags & SCF_WHILEM_VISITED_POS)
4302                         f |= SCF_WHILEM_VISITED_POS;
4303
4304                     /* we suppose the run is continuous, last=next...*/
4305                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4306                                       &deltanext, next, &data_fake, stopparen,
4307                                       recursed_depth, NULL, f,depth+1);
4308
4309                     if (min1 > minnext)
4310                         min1 = minnext;
4311                     if (deltanext == SSize_t_MAX) {
4312                         is_inf = is_inf_internal = 1;
4313                         max1 = SSize_t_MAX;
4314                     } else if (max1 < minnext + deltanext)
4315                         max1 = minnext + deltanext;
4316                     scan = next;
4317                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4318                         pars++;
4319                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4320                         if ( stopmin > minnext)
4321                             stopmin = min + min1;
4322                         flags &= ~SCF_DO_SUBSTR;
4323                         if (data)
4324                             data->flags |= SCF_SEEN_ACCEPT;
4325                     }
4326                     if (data) {
4327                         if (data_fake.flags & SF_HAS_EVAL)
4328                             data->flags |= SF_HAS_EVAL;
4329                         data->whilem_c = data_fake.whilem_c;
4330                     }
4331                     if (flags & SCF_DO_STCLASS)
4332                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4333                 }
4334                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4335                     min1 = 0;
4336                 if (flags & SCF_DO_SUBSTR) {
4337                     data->pos_min += min1;
4338                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4339                         data->pos_delta = SSize_t_MAX;
4340                     else
4341                         data->pos_delta += max1 - min1;
4342                     if (max1 != min1 || is_inf)
4343                         data->longest = &(data->longest_float);
4344                 }
4345                 min += min1;
4346                 if (delta == SSize_t_MAX
4347                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4348                     delta = SSize_t_MAX;
4349                 else
4350                     delta += max1 - min1;
4351                 if (flags & SCF_DO_STCLASS_OR) {
4352                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4353                     if (min1) {
4354                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4355                         flags &= ~SCF_DO_STCLASS;
4356                     }
4357                 }
4358                 else if (flags & SCF_DO_STCLASS_AND) {
4359                     if (min1) {
4360                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4361                         flags &= ~SCF_DO_STCLASS;
4362                     }
4363                     else {
4364                         /* Switch to OR mode: cache the old value of
4365                          * data->start_class */
4366                         INIT_AND_WITHP;
4367                         StructCopy(data->start_class, and_withp, regnode_ssc);
4368                         flags &= ~SCF_DO_STCLASS_AND;
4369                         StructCopy(&accum, data->start_class, regnode_ssc);
4370                         flags |= SCF_DO_STCLASS_OR;
4371                     }
4372                 }
4373
4374                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4375                         OP( startbranch ) == BRANCH )
4376                 {
4377                 /* demq.
4378
4379                    Assuming this was/is a branch we are dealing with: 'scan'
4380                    now points at the item that follows the branch sequence,
4381                    whatever it is. We now start at the beginning of the
4382                    sequence and look for subsequences of
4383
4384                    BRANCH->EXACT=>x1
4385                    BRANCH->EXACT=>x2
4386                    tail
4387
4388                    which would be constructed from a pattern like
4389                    /A|LIST|OF|WORDS/
4390
4391                    If we can find such a subsequence we need to turn the first
4392                    element into a trie and then add the subsequent branch exact
4393                    strings to the trie.
4394
4395                    We have two cases
4396
4397                      1. patterns where the whole set of branches can be
4398                         converted.
4399
4400                      2. patterns where only a subset can be converted.
4401
4402                    In case 1 we can replace the whole set with a single regop
4403                    for the trie. In case 2 we need to keep the start and end
4404                    branches so
4405
4406                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4407                      becomes BRANCH TRIE; BRANCH X;
4408
4409                   There is an additional case, that being where there is a
4410                   common prefix, which gets split out into an EXACT like node
4411                   preceding the TRIE node.
4412
4413                   If x(1..n)==tail then we can do a simple trie, if not we make
4414                   a "jump" trie, such that when we match the appropriate word
4415                   we "jump" to the appropriate tail node. Essentially we turn
4416                   a nested if into a case structure of sorts.
4417
4418                 */
4419
4420                     int made=0;
4421                     if (!re_trie_maxbuff) {
4422                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4423                         if (!SvIOK(re_trie_maxbuff))
4424                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4425                     }
4426                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4427                         regnode *cur;
4428                         regnode *first = (regnode *)NULL;
4429                         regnode *last = (regnode *)NULL;
4430                         regnode *tail = scan;
4431                         U8 trietype = 0;
4432                         U32 count=0;
4433
4434                         /* var tail is used because there may be a TAIL
4435                            regop in the way. Ie, the exacts will point to the
4436                            thing following the TAIL, but the last branch will
4437                            point at the TAIL. So we advance tail. If we
4438                            have nested (?:) we may have to move through several
4439                            tails.
4440                          */
4441
4442                         while ( OP( tail ) == TAIL ) {
4443                             /* this is the TAIL generated by (?:) */
4444                             tail = regnext( tail );
4445                         }
4446
4447
4448                         DEBUG_TRIE_COMPILE_r({
4449                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4450                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4451                               depth+1,
4452                               "Looking for TRIE'able sequences. Tail node is ",
4453                               (UV)(tail - RExC_emit_start),
4454                               SvPV_nolen_const( RExC_mysv )
4455                             );
4456                         });
4457
4458                         /*
4459
4460                             Step through the branches
4461                                 cur represents each branch,
4462                                 noper is the first thing to be matched as part
4463                                       of that branch
4464                                 noper_next is the regnext() of that node.
4465
4466                             We normally handle a case like this
4467                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4468                             support building with NOJUMPTRIE, which restricts
4469                             the trie logic to structures like /FOO|BAR/.
4470
4471                             If noper is a trieable nodetype then the branch is
4472                             a possible optimization target. If we are building
4473                             under NOJUMPTRIE then we require that noper_next is
4474                             the same as scan (our current position in the regex
4475                             program).
4476
4477                             Once we have two or more consecutive such branches
4478                             we can create a trie of the EXACT's contents and
4479                             stitch it in place into the program.
4480
4481                             If the sequence represents all of the branches in
4482                             the alternation we replace the entire thing with a
4483                             single TRIE node.
4484
4485                             Otherwise when it is a subsequence we need to
4486                             stitch it in place and replace only the relevant
4487                             branches. This means the first branch has to remain
4488                             as it is used by the alternation logic, and its
4489                             next pointer, and needs to be repointed at the item
4490                             on the branch chain following the last branch we
4491                             have optimized away.
4492
4493                             This could be either a BRANCH, in which case the
4494                             subsequence is internal, or it could be the item
4495                             following the branch sequence in which case the
4496                             subsequence is at the end (which does not
4497                             necessarily mean the first node is the start of the
4498                             alternation).
4499
4500                             TRIE_TYPE(X) is a define which maps the optype to a
4501                             trietype.
4502
4503                                 optype          |  trietype
4504                                 ----------------+-----------
4505                                 NOTHING         | NOTHING
4506                                 EXACT           | EXACT
4507                                 EXACTFU         | EXACTFU
4508                                 EXACTFU_SS      | EXACTFU
4509                                 EXACTFA         | EXACTFA
4510                                 EXACTL          | EXACTL
4511                                 EXACTFLU8       | EXACTFLU8
4512
4513
4514                         */
4515 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4516                        ? NOTHING                                            \
4517                        : ( EXACT == (X) )                                   \
4518                          ? EXACT                                            \
4519                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4520                            ? EXACTFU                                        \
4521                            : ( EXACTFA == (X) )                             \
4522                              ? EXACTFA                                      \
4523                              : ( EXACTL == (X) )                            \
4524                                ? EXACTL                                     \
4525                                : ( EXACTFLU8 == (X) )                        \
4526                                  ? EXACTFLU8                                 \
4527                                  : 0 )
4528
4529                         /* dont use tail as the end marker for this traverse */
4530                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4531                             regnode * const noper = NEXTOPER( cur );
4532                             U8 noper_type = OP( noper );
4533                             U8 noper_trietype = TRIE_TYPE( noper_type );
4534 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4535                             regnode * const noper_next = regnext( noper );
4536                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4537                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4538 #endif
4539
4540                             DEBUG_TRIE_COMPILE_r({
4541                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4542                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4543                                    depth+1,
4544                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4545
4546                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4547                                 Perl_re_printf( aTHX_  " -> %d:%s",
4548                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4549
4550                                 if ( noper_next ) {
4551                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4552                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4553                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4554                                 }
4555                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4556                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4557                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4558                                 );
4559                             });
4560
4561                             /* Is noper a trieable nodetype that can be merged
4562                              * with the current trie (if there is one)? */
4563                             if ( noper_trietype
4564                                   &&
4565                                   (
4566                                         ( noper_trietype == NOTHING )
4567                                         || ( trietype == NOTHING )
4568                                         || ( trietype == noper_trietype )
4569                                   )
4570 #ifdef NOJUMPTRIE
4571                                   && noper_next >= tail
4572 #endif
4573                                   && count < U16_MAX)
4574                             {
4575                                 /* Handle mergable triable node Either we are
4576                                  * the first node in a new trieable sequence,
4577                                  * in which case we do some bookkeeping,
4578                                  * otherwise we update the end pointer. */
4579                                 if ( !first ) {
4580                                     first = cur;
4581                                     if ( noper_trietype == NOTHING ) {
4582 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4583                                         regnode * const noper_next = regnext( noper );
4584                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4585                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4586 #endif
4587
4588                                         if ( noper_next_trietype ) {
4589                                             trietype = noper_next_trietype;
4590                                         } else if (noper_next_type)  {
4591                                             /* a NOTHING regop is 1 regop wide.
4592                                              * We need at least two for a trie
4593                                              * so we can't merge this in */
4594                                             first = NULL;
4595                                         }
4596                                     } else {
4597                                         trietype = noper_trietype;
4598                                     }
4599                                 } else {
4600                                     if ( trietype == NOTHING )
4601                                         trietype = noper_trietype;
4602                                     last = cur;
4603                                 }
4604                                 if (first)
4605                                     count++;
4606                             } /* end handle mergable triable node */
4607                             else {
4608                                 /* handle unmergable node -
4609                                  * noper may either be a triable node which can
4610                                  * not be tried together with the current trie,
4611                                  * or a non triable node */
4612                                 if ( last ) {
4613                                     /* If last is set and trietype is not
4614                                      * NOTHING then we have found at least two
4615                                      * triable branch sequences in a row of a
4616                                      * similar trietype so we can turn them
4617                                      * into a trie. If/when we allow NOTHING to
4618                                      * start a trie sequence this condition
4619                                      * will be required, and it isn't expensive
4620                                      * so we leave it in for now. */
4621                                     if ( trietype && trietype != NOTHING )
4622                                         make_trie( pRExC_state,
4623                                                 startbranch, first, cur, tail,
4624                                                 count, trietype, depth+1 );
4625                                     last = NULL; /* note: we clear/update
4626                                                     first, trietype etc below,
4627                                                     so we dont do it here */
4628                                 }
4629                                 if ( noper_trietype
4630 #ifdef NOJUMPTRIE
4631                                      && noper_next >= tail
4632 #endif
4633                                 ){
4634                                     /* noper is triable, so we can start a new
4635                                      * trie sequence */
4636                                     count = 1;
4637                                     first = cur;
4638                                     trietype = noper_trietype;
4639                                 } else if (first) {
4640                                     /* if we already saw a first but the
4641                                      * current node is not triable then we have
4642                                      * to reset the first information. */
4643                                     count = 0;
4644                                     first = NULL;
4645                                     trietype = 0;
4646                                 }
4647                             } /* end handle unmergable node */
4648                         } /* loop over branches */
4649                         DEBUG_TRIE_COMPILE_r({
4650                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4651                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4652                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4653                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4654                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4655                                PL_reg_name[trietype]
4656                             );
4657
4658                         });
4659                         if ( last && trietype ) {
4660                             if ( trietype != NOTHING ) {
4661                                 /* the last branch of the sequence was part of
4662                                  * a trie, so we have to construct it here
4663                                  * outside of the loop */
4664                                 made= make_trie( pRExC_state, startbranch,
4665                                                  first, scan, tail, count,
4666                                                  trietype, depth+1 );
4667 #ifdef TRIE_STUDY_OPT
4668                                 if ( ((made == MADE_EXACT_TRIE &&
4669                                      startbranch == first)
4670                                      || ( first_non_open == first )) &&
4671                                      depth==0 ) {
4672                                     flags |= SCF_TRIE_RESTUDY;
4673                                     if ( startbranch == first
4674                                          && scan >= tail )
4675                                     {
4676                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4677                                     }
4678                                 }
4679 #endif
4680                             } else {
4681                                 /* at this point we know whatever we have is a
4682                                  * NOTHING sequence/branch AND if 'startbranch'
4683                                  * is 'first' then we can turn the whole thing
4684                                  * into a NOTHING
4685                                  */
4686                                 if ( startbranch == first ) {
4687                                     regnode *opt;
4688                                     /* the entire thing is a NOTHING sequence,
4689                                      * something like this: (?:|) So we can
4690                                      * turn it into a plain NOTHING op. */
4691                                     DEBUG_TRIE_COMPILE_r({
4692                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4693                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4694                                           depth+1,
4695                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4696
4697                                     });
4698                                     OP(startbranch)= NOTHING;
4699                                     NEXT_OFF(startbranch)= tail - startbranch;
4700                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4701                                         OP(opt)= OPTIMIZED;
4702                                 }
4703                             }
4704                         } /* end if ( last) */
4705                     } /* TRIE_MAXBUF is non zero */
4706
4707                 } /* do trie */
4708
4709             }
4710             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4711                 scan = NEXTOPER(NEXTOPER(scan));
4712             } else                      /* single branch is optimized. */
4713                 scan = NEXTOPER(scan);
4714             continue;
4715         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4716             I32 paren = 0;
4717             regnode *start = NULL;
4718             regnode *end = NULL;
4719             U32 my_recursed_depth= recursed_depth;
4720
4721             if (OP(scan) != SUSPEND) { /* GOSUB */
4722                 /* Do setup, note this code has side effects beyond
4723                  * the rest of this block. Specifically setting
4724                  * RExC_recurse[] must happen at least once during
4725                  * study_chunk(). */
4726                 paren = ARG(scan);
4727                 RExC_recurse[ARG2L(scan)] = scan;
4728                 start = RExC_open_parens[paren];
4729                 end   = RExC_close_parens[paren];
4730
4731                 /* NOTE we MUST always execute the above code, even
4732                  * if we do nothing with a GOSUB */
4733                 if (
4734                     ( flags & SCF_IN_DEFINE )
4735                     ||
4736                     (
4737                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4738                         &&
4739                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4740                     )
4741                 ) {
4742                     /* no need to do anything here if we are in a define. */
4743                     /* or we are after some kind of infinite construct
4744                      * so we can skip recursing into this item.
4745                      * Since it is infinite we will not change the maxlen
4746                      * or delta, and if we miss something that might raise
4747                      * the minlen it will merely pessimise a little.
4748                      *
4749                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4750                      * might result in a minlen of 1 and not of 4,
4751                      * but this doesn't make us mismatch, just try a bit
4752                      * harder than we should.
4753                      * */
4754                     scan= regnext(scan);
4755                     continue;
4756                 }
4757
4758                 if (
4759                     !recursed_depth
4760                     ||
4761                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4762                 ) {
4763                     /* it is quite possible that there are more efficient ways
4764                      * to do this. We maintain a bitmap per level of recursion
4765                      * of which patterns we have entered so we can detect if a
4766                      * pattern creates a possible infinite loop. When we
4767                      * recurse down a level we copy the previous levels bitmap
4768                      * down. When we are at recursion level 0 we zero the top
4769                      * level bitmap. It would be nice to implement a different
4770                      * more efficient way of doing this. In particular the top
4771                      * level bitmap may be unnecessary.
4772                      */
4773                     if (!recursed_depth) {
4774                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4775                     } else {
4776                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4777                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4778                              RExC_study_chunk_recursed_bytes, U8);
4779                     }
4780                     /* we havent recursed into this paren yet, so recurse into it */
4781                     DEBUG_STUDYDATA("gosub-set:", data,depth);
4782                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4783                     my_recursed_depth= recursed_depth + 1;
4784                 } else {
4785                     DEBUG_STUDYDATA("gosub-inf:", data,depth);
4786                     /* some form of infinite recursion, assume infinite length
4787                      * */
4788                     if (flags & SCF_DO_SUBSTR) {
4789                         scan_commit(pRExC_state, data, minlenp, is_inf);
4790                         data->longest = &(data->longest_float);
4791                     }
4792                     is_inf = is_inf_internal = 1;
4793                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4794                         ssc_anything(data->start_class);
4795                     flags &= ~SCF_DO_STCLASS;
4796
4797                     start= NULL; /* reset start so we dont recurse later on. */
4798                 }
4799             } else {
4800                 paren = stopparen;
4801                 start = scan + 2;
4802                 end = regnext(scan);
4803             }
4804             if (start) {
4805                 scan_frame *newframe;
4806                 assert(end);
4807                 if (!RExC_frame_last) {
4808                     Newxz(newframe, 1, scan_frame);
4809                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4810                     RExC_frame_head= newframe;
4811                     RExC_frame_count++;
4812                 } else if (!RExC_frame_last->next_frame) {
4813                     Newxz(newframe,1,scan_frame);
4814                     RExC_frame_last->next_frame= newframe;
4815                     newframe->prev_frame= RExC_frame_last;
4816                     RExC_frame_count++;
4817                 } else {
4818                     newframe= RExC_frame_last->next_frame;
4819                 }
4820                 RExC_frame_last= newframe;
4821
4822                 newframe->next_regnode = regnext(scan);
4823                 newframe->last_regnode = last;
4824                 newframe->stopparen = stopparen;
4825                 newframe->prev_recursed_depth = recursed_depth;
4826                 newframe->this_prev_frame= frame;
4827
4828                 DEBUG_STUDYDATA("frame-new:",data,depth);
4829                 DEBUG_PEEP("fnew", scan, depth);
4830
4831                 frame = newframe;
4832                 scan =  start;
4833                 stopparen = paren;
4834                 last = end;
4835                 depth = depth + 1;
4836                 recursed_depth= my_recursed_depth;
4837
4838                 continue;
4839             }
4840         }
4841         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4842             SSize_t l = STR_LEN(scan);
4843             UV uc;
4844             if (UTF) {
4845                 const U8 * const s = (U8*)STRING(scan);
4846                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4847                 l = utf8_length(s, s + l);
4848             } else {
4849                 uc = *((U8*)STRING(scan));
4850             }
4851             min += l;
4852             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4853                 /* The code below prefers earlier match for fixed
4854                    offset, later match for variable offset.  */
4855                 if (data->last_end == -1) { /* Update the start info. */
4856                     data->last_start_min = data->pos_min;
4857                     data->last_start_max = is_inf
4858                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4859                 }
4860                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4861                 if (UTF)
4862                     SvUTF8_on(data->last_found);
4863                 {
4864                     SV * const sv = data->last_found;
4865                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4866                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4867                     if (mg && mg->mg_len >= 0)
4868                         mg->mg_len += utf8_length((U8*)STRING(scan),
4869                                               (U8*)STRING(scan)+STR_LEN(scan));
4870                 }
4871                 data->last_end = data->pos_min + l;
4872                 data->pos_min += l; /* As in the first entry. */
4873                 data->flags &= ~SF_BEFORE_EOL;
4874             }
4875
4876             /* ANDing the code point leaves at most it, and not in locale, and
4877              * can't match null string */
4878             if (flags & SCF_DO_STCLASS_AND) {
4879                 ssc_cp_and(data->start_class, uc);
4880                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4881                 ssc_clear_locale(data->start_class);
4882             }
4883             else if (flags & SCF_DO_STCLASS_OR) {
4884                 ssc_add_cp(data->start_class, uc);
4885                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4886
4887                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4888                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4889             }
4890             flags &= ~SCF_DO_STCLASS;
4891         }
4892         else if (PL_regkind[OP(scan)] == EXACT) {
4893             /* But OP != EXACT!, so is EXACTFish */
4894             SSize_t l = STR_LEN(scan);
4895             const U8 * s = (U8*)STRING(scan);
4896
4897             /* Search for fixed substrings supports EXACT only. */
4898             if (flags & SCF_DO_SUBSTR) {
4899                 assert(data);
4900                 scan_commit(pRExC_state, data, minlenp, is_inf);
4901             }
4902             if (UTF) {
4903                 l = utf8_length(s, s + l);
4904             }
4905             if (unfolded_multi_char) {
4906                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4907             }
4908             min += l - min_subtract;
4909             assert (min >= 0);
4910             delta += min_subtract;
4911             if (flags & SCF_DO_SUBSTR) {
4912                 data->pos_min += l - min_subtract;
4913                 if (data->pos_min < 0) {
4914                     data->pos_min = 0;
4915                 }
4916                 data->pos_delta += min_subtract;
4917                 if (min_subtract) {
4918                     data->longest = &(data->longest_float);
4919                 }
4920             }
4921
4922             if (flags & SCF_DO_STCLASS) {
4923                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4924
4925                 assert(EXACTF_invlist);
4926                 if (flags & SCF_DO_STCLASS_AND) {
4927                     if (OP(scan) != EXACTFL)
4928                         ssc_clear_locale(data->start_class);
4929                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4930                     ANYOF_POSIXL_ZERO(data->start_class);
4931                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4932                 }
4933                 else {  /* SCF_DO_STCLASS_OR */
4934                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4935                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4936
4937                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4938                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4939                 }
4940                 flags &= ~SCF_DO_STCLASS;
4941                 SvREFCNT_dec(EXACTF_invlist);
4942             }
4943         }
4944         else if (REGNODE_VARIES(OP(scan))) {
4945             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4946             I32 fl = 0, f = flags;
4947             regnode * const oscan = scan;
4948             regnode_ssc this_class;
4949             regnode_ssc *oclass = NULL;
4950             I32 next_is_eval = 0;
4951
4952             switch (PL_regkind[OP(scan)]) {
4953             case WHILEM:                /* End of (?:...)* . */
4954                 scan = NEXTOPER(scan);
4955                 goto finish;
4956             case PLUS:
4957                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4958                     next = NEXTOPER(scan);
4959                     if (OP(next) == EXACT
4960                         || OP(next) == EXACTL
4961                         || (flags & SCF_DO_STCLASS))
4962                     {
4963                         mincount = 1;
4964                         maxcount = REG_INFTY;
4965                         next = regnext(scan);
4966                         scan = NEXTOPER(scan);
4967                         goto do_curly;
4968                     }
4969                 }
4970                 if (flags & SCF_DO_SUBSTR)
4971                     data->pos_min++;
4972                 min++;
4973                 /* FALLTHROUGH */
4974             case STAR:
4975                 if (flags & SCF_DO_STCLASS) {
4976                     mincount = 0;
4977                     maxcount = REG_INFTY;
4978                     next = regnext(scan);
4979                     scan = NEXTOPER(scan);
4980                     goto do_curly;
4981                 }
4982                 if (flags & SCF_DO_SUBSTR) {
4983                     scan_commit(pRExC_state, data, minlenp, is_inf);
4984                     /* Cannot extend fixed substrings */
4985                     data->longest = &(data->longest_float);
4986                 }
4987                 is_inf = is_inf_internal = 1;
4988                 scan = regnext(scan);
4989                 goto optimize_curly_tail;
4990             case CURLY:
4991                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4992                     && (scan->flags == stopparen))
4993                 {
4994                     mincount = 1;
4995                     maxcount = 1;
4996                 } else {
4997                     mincount = ARG1(scan);
4998                     maxcount = ARG2(scan);
4999                 }
5000                 next = regnext(scan);
5001                 if (OP(scan) == CURLYX) {
5002                     I32 lp = (data ? *(data->last_closep) : 0);
5003                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5004                 }
5005                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5006                 next_is_eval = (OP(scan) == EVAL);
5007               do_curly:
5008                 if (flags & SCF_DO_SUBSTR) {
5009                     if (mincount == 0)
5010                         scan_commit(pRExC_state, data, minlenp, is_inf);
5011                     /* Cannot extend fixed substrings */
5012                     pos_before = data->pos_min;
5013                 }
5014                 if (data) {
5015                     fl = data->flags;
5016                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5017                     if (is_inf)
5018                         data->flags |= SF_IS_INF;
5019                 }
5020                 if (flags & SCF_DO_STCLASS) {
5021                     ssc_init(pRExC_state, &this_class);
5022                     oclass = data->start_class;
5023                     data->start_class = &this_class;
5024                     f |= SCF_DO_STCLASS_AND;
5025                     f &= ~SCF_DO_STCLASS_OR;
5026                 }
5027                 /* Exclude from super-linear cache processing any {n,m}
5028                    regops for which the combination of input pos and regex
5029                    pos is not enough information to determine if a match
5030                    will be possible.
5031
5032                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5033                    regex pos at the \s*, the prospects for a match depend not
5034                    only on the input position but also on how many (bar\s*)
5035                    repeats into the {4,8} we are. */
5036                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5037                     f &= ~SCF_WHILEM_VISITED_POS;
5038
5039                 /* This will finish on WHILEM, setting scan, or on NULL: */
5040                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5041                                   last, data, stopparen, recursed_depth, NULL,
5042                                   (mincount == 0
5043                                    ? (f & ~SCF_DO_SUBSTR)
5044                                    : f)
5045                                   ,depth+1);
5046
5047                 if (flags & SCF_DO_STCLASS)
5048                     data->start_class = oclass;
5049                 if (mincount == 0 || minnext == 0) {
5050                     if (flags & SCF_DO_STCLASS_OR) {
5051                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5052                     }
5053                     else if (flags & SCF_DO_STCLASS_AND) {
5054                         /* Switch to OR mode: cache the old value of
5055                          * data->start_class */
5056                         INIT_AND_WITHP;
5057                         StructCopy(data->start_class, and_withp, regnode_ssc);
5058                         flags &= ~SCF_DO_STCLASS_AND;
5059                         StructCopy(&this_class, data->start_class, regnode_ssc);
5060                         flags |= SCF_DO_STCLASS_OR;
5061                         ANYOF_FLAGS(data->start_class)
5062                                                 |= SSC_MATCHES_EMPTY_STRING;
5063                     }
5064                 } else {                /* Non-zero len */
5065                     if (flags & SCF_DO_STCLASS_OR) {
5066                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5067                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5068                     }
5069                     else if (flags & SCF_DO_STCLASS_AND)
5070                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5071                     flags &= ~SCF_DO_STCLASS;
5072                 }
5073                 if (!scan)              /* It was not CURLYX, but CURLY. */
5074                     scan = next;
5075                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
5076                     /* ? quantifier ok, except for (?{ ... }) */
5077                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5078                     && (minnext == 0) && (deltanext == 0)
5079                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5080                     && maxcount <= REG_INFTY/3) /* Complement check for big
5081                                                    count */
5082                 {
5083                     /* Fatal warnings may leak the regexp without this: */
5084                     SAVEFREESV(RExC_rx_sv);
5085                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5086                         "Quantifier unexpected on zero-length expression "
5087                         "in regex m/%" UTF8f "/",
5088                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5089                                   RExC_precomp));
5090                     (void)ReREFCNT_inc(RExC_rx_sv);
5091                 }
5092
5093                 min += minnext * mincount;
5094                 is_inf_internal |= deltanext == SSize_t_MAX
5095                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5096                 is_inf |= is_inf_internal;
5097                 if (is_inf) {
5098                     delta = SSize_t_MAX;
5099                 } else {
5100                     delta += (minnext + deltanext) * maxcount
5101                              - minnext * mincount;
5102                 }
5103                 /* Try powerful optimization CURLYX => CURLYN. */
5104                 if (  OP(oscan) == CURLYX && data
5105                       && data->flags & SF_IN_PAR
5106                       && !(data->flags & SF_HAS_EVAL)
5107                       && !deltanext && minnext == 1 ) {
5108                     /* Try to optimize to CURLYN.  */
5109                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5110                     regnode * const nxt1 = nxt;
5111 #ifdef DEBUGGING
5112                     regnode *nxt2;
5113 #endif
5114
5115                     /* Skip open. */
5116                     nxt = regnext(nxt);
5117                     if (!REGNODE_SIMPLE(OP(nxt))
5118                         && !(PL_regkind[OP(nxt)] == EXACT
5119                              && STR_LEN(nxt) == 1))
5120                         goto nogo;
5121 #ifdef DEBUGGING
5122                     nxt2 = nxt;
5123 #endif
5124                     nxt = regnext(nxt);
5125                     if (OP(nxt) != CLOSE)
5126                         goto nogo;
5127                     if (RExC_open_parens) {
5128                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5129                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5130                     }
5131                     /* Now we know that nxt2 is the only contents: */
5132                     oscan->flags = (U8)ARG(nxt);
5133                     OP(oscan) = CURLYN;
5134                     OP(nxt1) = NOTHING; /* was OPEN. */
5135
5136 #ifdef DEBUGGING
5137                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5138                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5139                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5140                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5141                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5142                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5143 #endif
5144                 }
5145               nogo:
5146
5147                 /* Try optimization CURLYX => CURLYM. */
5148                 if (  OP(oscan) == CURLYX && data
5149                       && !(data->flags & SF_HAS_PAR)
5150                       && !(data->flags & SF_HAS_EVAL)
5151                       && !deltanext     /* atom is fixed width */
5152                       && minnext != 0   /* CURLYM can't handle zero width */
5153
5154                          /* Nor characters whose fold at run-time may be
5155                           * multi-character */
5156                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5157                 ) {
5158                     /* XXXX How to optimize if data == 0? */
5159                     /* Optimize to a simpler form.  */
5160                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5161                     regnode *nxt2;
5162
5163                     OP(oscan) = CURLYM;
5164                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5165                             && (OP(nxt2) != WHILEM))
5166                         nxt = nxt2;
5167                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5168                     /* Need to optimize away parenths. */
5169                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5170                         /* Set the parenth number.  */
5171                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5172
5173                         oscan->flags = (U8)ARG(nxt);
5174                         if (RExC_open_parens) {
5175                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5176                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5177                         }
5178                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5179                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5180
5181 #ifdef DEBUGGING
5182                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5183                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5184                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5185                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5186 #endif
5187 #if 0
5188                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5189                             regnode *nnxt = regnext(nxt1);
5190                             if (nnxt == nxt) {
5191                                 if (reg_off_by_arg[OP(nxt1)])
5192                                     ARG_SET(nxt1, nxt2 - nxt1);
5193                                 else if (nxt2 - nxt1 < U16_MAX)
5194                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5195                                 else
5196                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5197                             }
5198                             nxt1 = nnxt;
5199                         }
5200 #endif
5201                         /* Optimize again: */
5202                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5203                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5204                     }
5205                     else
5206                         oscan->flags = 0;
5207                 }
5208                 else if ((OP(oscan) == CURLYX)
5209                          && (flags & SCF_WHILEM_VISITED_POS)
5210                          /* See the comment on a similar expression above.
5211                             However, this time it's not a subexpression
5212                             we care about, but the expression itself. */
5213                          && (maxcount == REG_INFTY)
5214                          && data) {
5215                     /* This stays as CURLYX, we can put the count/of pair. */
5216                     /* Find WHILEM (as in regexec.c) */
5217                     regnode *nxt = oscan + NEXT_OFF(oscan);
5218
5219                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5220                         nxt += ARG(nxt);
5221                     nxt = PREVOPER(nxt);
5222                     if (nxt->flags & 0xf) {
5223                         /* we've already set whilem count on this node */
5224                     } else if (++data->whilem_c < 16) {
5225                         assert(data->whilem_c <= RExC_whilem_seen);
5226                         nxt->flags = (U8)(data->whilem_c
5227                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5228                     }
5229                 }
5230                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5231                     pars++;
5232                 if (flags & SCF_DO_SUBSTR) {
5233                     SV *last_str = NULL;
5234                     STRLEN last_chrs = 0;
5235                     int counted = mincount != 0;
5236
5237                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5238                                                                   string. */
5239                         SSize_t b = pos_before >= data->last_start_min
5240                             ? pos_before : data->last_start_min;
5241                         STRLEN l;
5242                         const char * const s = SvPV_const(data->last_found, l);
5243                         SSize_t old = b - data->last_start_min;
5244
5245                         if (UTF)
5246                             old = utf8_hop((U8*)s, old) - (U8*)s;
5247                         l -= old;
5248                         /* Get the added string: */
5249                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5250                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5251                                             (U8*)(s + old + l)) : l;
5252                         if (deltanext == 0 && pos_before == b) {
5253                             /* What was added is a constant string */
5254                             if (mincount > 1) {
5255
5256                                 SvGROW(last_str, (mincount * l) + 1);
5257                                 repeatcpy(SvPVX(last_str) + l,
5258                                           SvPVX_const(last_str), l,
5259                                           mincount - 1);
5260                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5261                                 /* Add additional parts. */
5262                                 SvCUR_set(data->last_found,
5263                                           SvCUR(data->last_found) - l);
5264                                 sv_catsv(data->last_found, last_str);
5265                                 {
5266                                     SV * sv = data->last_found;
5267                                     MAGIC *mg =
5268                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5269                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5270                                     if (mg && mg->mg_len >= 0)
5271                                         mg->mg_len += last_chrs * (mincount-1);
5272                                 }
5273                                 last_chrs *= mincount;
5274                                 data->last_end += l * (mincount - 1);
5275                             }
5276                         } else {
5277                             /* start offset must point into the last copy */
5278                             data->last_start_min += minnext * (mincount - 1);
5279                             data->last_start_max =
5280                               is_inf
5281                                ? SSize_t_MAX
5282                                : data->last_start_max +
5283                                  (maxcount - 1) * (minnext + data->pos_delta);
5284                         }
5285                     }
5286                     /* It is counted once already... */
5287                     data->pos_min += minnext * (mincount - counted);
5288 #if 0
5289 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5290                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5291                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5292     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5293     (UV)mincount);
5294 if (deltanext != SSize_t_MAX)
5295 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5296     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5297           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5298 #endif
5299                     if (deltanext == SSize_t_MAX
5300                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5301                         data->pos_delta = SSize_t_MAX;
5302                     else
5303                         data->pos_delta += - counted * deltanext +
5304                         (minnext + deltanext) * maxcount - minnext * mincount;
5305                     if (mincount != maxcount) {
5306                          /* Cannot extend fixed substrings found inside
5307                             the group.  */
5308                         scan_commit(pRExC_state, data, minlenp, is_inf);
5309                         if (mincount && last_str) {
5310                             SV * const sv = data->last_found;
5311                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5312                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5313
5314                             if (mg)
5315                                 mg->mg_len = -1;
5316                             sv_setsv(sv, last_str);
5317                             data->last_end = data->pos_min;
5318                             data->last_start_min = data->pos_min - last_chrs;
5319                             data->last_start_max = is_inf
5320                                 ? SSize_t_MAX
5321                                 : data->pos_min + data->pos_delta - last_chrs;
5322                         }
5323                         data->longest = &(data->longest_float);
5324                     }
5325                     SvREFCNT_dec(last_str);
5326                 }
5327                 if (data && (fl & SF_HAS_EVAL))
5328                     data->flags |= SF_HAS_EVAL;
5329               optimize_curly_tail:
5330                 if (OP(oscan) != CURLYX) {
5331                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5332                            && NEXT_OFF(next))
5333                         NEXT_OFF(oscan) += NEXT_OFF(next);
5334                 }
5335                 continue;
5336
5337             default:
5338 #ifdef DEBUGGING
5339                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5340                                                                     OP(scan));
5341 #endif
5342             case REF:
5343             case CLUMP:
5344                 if (flags & SCF_DO_SUBSTR) {
5345                     /* Cannot expect anything... */
5346                     scan_commit(pRExC_state, data, minlenp, is_inf);
5347                     data->longest = &(data->longest_float);
5348                 }
5349                 is_inf = is_inf_internal = 1;
5350                 if (flags & SCF_DO_STCLASS_OR) {
5351                     if (OP(scan) == CLUMP) {
5352                         /* Actually is any start char, but very few code points
5353                          * aren't start characters */
5354                         ssc_match_all_cp(data->start_class);
5355                     }
5356                     else {
5357                         ssc_anything(data->start_class);
5358                     }
5359                 }
5360                 flags &= ~SCF_DO_STCLASS;
5361                 break;
5362             }
5363         }
5364         else if (OP(scan) == LNBREAK) {
5365             if (flags & SCF_DO_STCLASS) {
5366                 if (flags & SCF_DO_STCLASS_AND) {
5367                     ssc_intersection(data->start_class,
5368                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5369                     ssc_clear_locale(data->start_class);
5370                     ANYOF_FLAGS(data->start_class)
5371                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5372                 }
5373                 else if (flags & SCF_DO_STCLASS_OR) {
5374                     ssc_union(data->start_class,
5375                               PL_XPosix_ptrs[_CC_VERTSPACE],
5376                               FALSE);
5377                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5378
5379                     /* See commit msg for
5380                      * 749e076fceedeb708a624933726e7989f2302f6a */
5381                     ANYOF_FLAGS(data->start_class)
5382                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5383                 }
5384                 flags &= ~SCF_DO_STCLASS;
5385             }
5386             min++;
5387             if (delta != SSize_t_MAX)
5388                 delta++;    /* Because of the 2 char string cr-lf */
5389             if (flags & SCF_DO_SUBSTR) {
5390                 /* Cannot expect anything... */
5391                 scan_commit(pRExC_state, data, minlenp, is_inf);
5392                 data->pos_min += 1;
5393                 data->pos_delta += 1;
5394                 data->longest = &(data->longest_float);
5395             }
5396         }
5397         else if (REGNODE_SIMPLE(OP(scan))) {
5398
5399             if (flags & SCF_DO_SUBSTR) {
5400                 scan_commit(pRExC_state, data, minlenp, is_inf);
5401                 data->pos_min++;
5402             }
5403             min++;
5404             if (flags & SCF_DO_STCLASS) {
5405                 bool invert = 0;
5406                 SV* my_invlist = NULL;
5407                 U8 namedclass;
5408
5409                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5410                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5411
5412                 /* Some of the logic below assumes that switching
5413                    locale on will only add false positives. */
5414                 switch (OP(scan)) {
5415
5416                 default:
5417 #ifdef DEBUGGING
5418                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5419                                                                      OP(scan));
5420 #endif
5421                 case SANY:
5422                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5423                         ssc_match_all_cp(data->start_class);
5424                     break;
5425
5426                 case REG_ANY:
5427                     {
5428                         SV* REG_ANY_invlist = _new_invlist(2);
5429                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5430                                                             '\n');
5431                         if (flags & SCF_DO_STCLASS_OR) {
5432                             ssc_union(data->start_class,
5433                                       REG_ANY_invlist,
5434                                       TRUE /* TRUE => invert, hence all but \n
5435                                             */
5436                                       );
5437                         }
5438                         else if (flags & SCF_DO_STCLASS_AND) {
5439                             ssc_intersection(data->start_class,
5440                                              REG_ANY_invlist,
5441                                              TRUE  /* TRUE => invert */
5442                                              );
5443                             ssc_clear_locale(data->start_class);
5444                         }
5445                         SvREFCNT_dec_NN(REG_ANY_invlist);
5446                     }
5447                     break;
5448
5449                 case ANYOFD:
5450                 case ANYOFL:
5451                 case ANYOF:
5452                     if (flags & SCF_DO_STCLASS_AND)
5453                         ssc_and(pRExC_state, data->start_class,
5454                                 (regnode_charclass *) scan);
5455                     else
5456                         ssc_or(pRExC_state, data->start_class,
5457                                                           (regnode_charclass *) scan);
5458                     break;
5459
5460                 case NPOSIXL:
5461                     invert = 1;
5462                     /* FALLTHROUGH */
5463
5464                 case POSIXL:
5465                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5466                     if (flags & SCF_DO_STCLASS_AND) {
5467                         bool was_there = cBOOL(
5468                                           ANYOF_POSIXL_TEST(data->start_class,
5469                                                                  namedclass));
5470                         ANYOF_POSIXL_ZERO(data->start_class);
5471                         if (was_there) {    /* Do an AND */
5472                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5473                         }
5474                         /* No individual code points can now match */
5475                         data->start_class->invlist
5476                                                 = sv_2mortal(_new_invlist(0));
5477                     }
5478                     else {
5479                         int complement = namedclass + ((invert) ? -1 : 1);
5480
5481                         assert(flags & SCF_DO_STCLASS_OR);
5482
5483                         /* If the complement of this class was already there,
5484                          * the result is that they match all code points,
5485                          * (\d + \D == everything).  Remove the classes from
5486                          * future consideration.  Locale is not relevant in
5487                          * this case */
5488                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5489                             ssc_match_all_cp(data->start_class);
5490                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5491                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5492                         }
5493                         else {  /* The usual case; just add this class to the
5494                                    existing set */
5495                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5496                         }
5497                     }
5498                     break;
5499
5500                 case NPOSIXA:   /* For these, we always know the exact set of
5501                                    what's matched */
5502                     invert = 1;
5503                     /* FALLTHROUGH */
5504                 case POSIXA:
5505                     if (FLAGS(scan) == _CC_ASCII) {
5506                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5507                     }
5508                     else {
5509                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5510                                               PL_XPosix_ptrs[_CC_ASCII],
5511                                               &my_invlist);
5512                     }
5513                     goto join_posix;
5514
5515                 case NPOSIXD:
5516                 case NPOSIXU:
5517                     invert = 1;
5518                     /* FALLTHROUGH */
5519                 case POSIXD:
5520                 case POSIXU:
5521                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5522
5523                     /* NPOSIXD matches all upper Latin1 code points unless the
5524                      * target string being matched is UTF-8, which is
5525                      * unknowable until match time.  Since we are going to
5526                      * invert, we want to get rid of all of them so that the
5527                      * inversion will match all */
5528                     if (OP(scan) == NPOSIXD) {
5529                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5530                                           &my_invlist);
5531                     }
5532
5533                   join_posix:
5534
5535                     if (flags & SCF_DO_STCLASS_AND) {
5536                         ssc_intersection(data->start_class, my_invlist, invert);
5537                         ssc_clear_locale(data->start_class);
5538                     }
5539                     else {
5540                         assert(flags & SCF_DO_STCLASS_OR);
5541                         ssc_union(data->start_class, my_invlist, invert);
5542                     }
5543                     SvREFCNT_dec(my_invlist);
5544                 }
5545                 if (flags & SCF_DO_STCLASS_OR)
5546                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5547                 flags &= ~SCF_DO_STCLASS;
5548             }
5549         }
5550         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5551             data->flags |= (OP(scan) == MEOL
5552                             ? SF_BEFORE_MEOL
5553                             : SF_BEFORE_SEOL);
5554             scan_commit(pRExC_state, data, minlenp, is_inf);
5555
5556         }
5557         else if (  PL_regkind[OP(scan)] == BRANCHJ
5558                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5559                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5560                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5561         {
5562             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5563                 || OP(scan) == UNLESSM )
5564             {
5565                 /* Negative Lookahead/lookbehind
5566                    In this case we can't do fixed string optimisation.
5567                 */
5568
5569                 SSize_t deltanext, minnext, fake = 0;
5570                 regnode *nscan;
5571                 regnode_ssc intrnl;
5572                 int f = 0;
5573
5574                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5575                 if (data) {
5576                     data_fake.whilem_c = data->whilem_c;
5577                     data_fake.last_closep = data->last_closep;
5578                 }
5579                 else
5580                     data_fake.last_closep = &fake;
5581                 data_fake.pos_delta = delta;
5582                 if ( flags & SCF_DO_STCLASS && !scan->flags
5583                      && OP(scan) == IFMATCH ) { /* Lookahead */
5584                     ssc_init(pRExC_state, &intrnl);
5585                     data_fake.start_class = &intrnl;
5586                     f |= SCF_DO_STCLASS_AND;
5587                 }
5588                 if (flags & SCF_WHILEM_VISITED_POS)
5589                     f |= SCF_WHILEM_VISITED_POS;
5590                 next = regnext(scan);
5591                 nscan = NEXTOPER(NEXTOPER(scan));
5592                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5593                                       last, &data_fake, stopparen,
5594                                       recursed_depth, NULL, f, depth+1);
5595                 if (scan->flags) {
5596                     if (deltanext) {
5597                         FAIL("Variable length lookbehind not implemented");
5598                     }
5599                     else if (minnext > (I32)U8_MAX) {
5600                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5601                               (UV)U8_MAX);
5602                     }
5603                     scan->flags = (U8)minnext;
5604                 }
5605                 if (data) {
5606                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5607                         pars++;
5608                     if (data_fake.flags & SF_HAS_EVAL)
5609                         data->flags |= SF_HAS_EVAL;
5610                     data->whilem_c = data_fake.whilem_c;
5611                 }
5612                 if (f & SCF_DO_STCLASS_AND) {
5613                     if (flags & SCF_DO_STCLASS_OR) {
5614                         /* OR before, AND after: ideally we would recurse with
5615                          * data_fake to get the AND applied by study of the
5616                          * remainder of the pattern, and then derecurse;
5617                          * *** HACK *** for now just treat as "no information".
5618                          * See [perl #56690].
5619                          */
5620                         ssc_init(pRExC_state, data->start_class);
5621                     }  else {
5622                         /* AND before and after: combine and continue.  These
5623                          * assertions are zero-length, so can match an EMPTY
5624                          * string */
5625                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5626                         ANYOF_FLAGS(data->start_class)
5627                                                    |= SSC_MATCHES_EMPTY_STRING;
5628                     }
5629                 }
5630             }
5631 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5632             else {
5633                 /* Positive Lookahead/lookbehind
5634                    In this case we can do fixed string optimisation,
5635                    but we must be careful about it. Note in the case of
5636                    lookbehind the positions will be offset by the minimum
5637                    length of the pattern, something we won't know about
5638                    until after the recurse.
5639                 */
5640                 SSize_t deltanext, fake = 0;
5641                 regnode *nscan;
5642                 regnode_ssc intrnl;
5643                 int f = 0;
5644                 /* We use SAVEFREEPV so that when the full compile
5645                     is finished perl will clean up the allocated
5646                     minlens when it's all done. This way we don't
5647                     have to worry about freeing them when we know
5648                     they wont be used, which would be a pain.
5649                  */
5650                 SSize_t *minnextp;
5651                 Newx( minnextp, 1, SSize_t );
5652                 SAVEFREEPV(minnextp);
5653
5654                 if (data) {
5655                     StructCopy(data, &data_fake, scan_data_t);
5656                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5657                         f |= SCF_DO_SUBSTR;
5658                         if (scan->flags)
5659                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5660                         data_fake.last_found=newSVsv(data->last_found);
5661                     }
5662                 }
5663                 else
5664                     data_fake.last_closep = &fake;
5665                 data_fake.flags = 0;
5666                 data_fake.pos_delta = delta;
5667                 if (is_inf)
5668                     data_fake.flags |= SF_IS_INF;
5669                 if ( flags & SCF_DO_STCLASS && !scan->flags
5670                      && OP(scan) == IFMATCH ) { /* Lookahead */
5671                     ssc_init(pRExC_state, &intrnl);
5672                     data_fake.start_class = &intrnl;
5673                     f |= SCF_DO_STCLASS_AND;
5674                 }
5675                 if (flags & SCF_WHILEM_VISITED_POS)
5676                     f |= SCF_WHILEM_VISITED_POS;
5677                 next = regnext(scan);
5678                 nscan = NEXTOPER(NEXTOPER(scan));
5679
5680                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5681                                         &deltanext, last, &data_fake,
5682                                         stopparen, recursed_depth, NULL,
5683                                         f,depth+1);
5684                 if (scan->flags) {
5685                     if (deltanext) {
5686                         FAIL("Variable length lookbehind not implemented");
5687                     }
5688                     else if (*minnextp > (I32)U8_MAX) {
5689                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5690                               (UV)U8_MAX);
5691                     }
5692                     scan->flags = (U8)*minnextp;
5693                 }
5694
5695                 *minnextp += min;
5696
5697                 if (f & SCF_DO_STCLASS_AND) {
5698                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5699                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5700                 }
5701                 if (data) {
5702                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5703                         pars++;
5704                     if (data_fake.flags & SF_HAS_EVAL)
5705                         data->flags |= SF_HAS_EVAL;
5706                     data->whilem_c = data_fake.whilem_c;
5707                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5708                         if (RExC_rx->minlen<*minnextp)
5709                             RExC_rx->minlen=*minnextp;
5710                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5711                         SvREFCNT_dec_NN(data_fake.last_found);
5712
5713                         if ( data_fake.minlen_fixed != minlenp )
5714                         {
5715                             data->offset_fixed= data_fake.offset_fixed;
5716                             data->minlen_fixed= data_fake.minlen_fixed;
5717                             data->lookbehind_fixed+= scan->flags;
5718                         }
5719                         if ( data_fake.minlen_float != minlenp )
5720                         {
5721                             data->minlen_float= data_fake.minlen_float;
5722                             data->offset_float_min=data_fake.offset_float_min;
5723                             data->offset_float_max=data_fake.offset_float_max;
5724                             data->lookbehind_float+= scan->flags;
5725                         }
5726                     }
5727                 }
5728             }
5729 #endif
5730         }
5731         else if (OP(scan) == OPEN) {
5732             if (stopparen != (I32)ARG(scan))
5733                 pars++;
5734         }
5735         else if (OP(scan) == CLOSE) {
5736             if (stopparen == (I32)ARG(scan)) {
5737                 break;
5738             }
5739             if ((I32)ARG(scan) == is_par) {
5740                 next = regnext(scan);
5741
5742                 if ( next && (OP(next) != WHILEM) && next < last)
5743                     is_par = 0;         /* Disable optimization */
5744             }
5745             if (data)
5746                 *(data->last_closep) = ARG(scan);
5747         }
5748         else if (OP(scan) == EVAL) {
5749                 if (data)
5750                     data->flags |= SF_HAS_EVAL;
5751         }
5752         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5753             if (flags & SCF_DO_SUBSTR) {
5754                 scan_commit(pRExC_state, data, minlenp, is_inf);
5755                 flags &= ~SCF_DO_SUBSTR;
5756             }
5757             if (data && OP(scan)==ACCEPT) {
5758                 data->flags |= SCF_SEEN_ACCEPT;
5759                 if (stopmin > min)
5760                     stopmin = min;
5761             }
5762         }
5763         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5764         {
5765                 if (flags & SCF_DO_SUBSTR) {
5766                     scan_commit(pRExC_state, data, minlenp, is_inf);
5767                     data->longest = &(data->longest_float);
5768                 }
5769                 is_inf = is_inf_internal = 1;
5770                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5771                     ssc_anything(data->start_class);
5772                 flags &= ~SCF_DO_STCLASS;
5773         }
5774         else if (OP(scan) == GPOS) {
5775             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5776                 !(delta || is_inf || (data && data->pos_delta)))
5777             {
5778                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5779                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5780                 if (RExC_rx->gofs < (STRLEN)min)
5781                     RExC_rx->gofs = min;
5782             } else {
5783                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5784                 RExC_rx->gofs = 0;
5785             }
5786         }
5787 #ifdef TRIE_STUDY_OPT
5788 #ifdef FULL_TRIE_STUDY
5789         else if (PL_regkind[OP(scan)] == TRIE) {
5790             /* NOTE - There is similar code to this block above for handling
5791                BRANCH nodes on the initial study.  If you change stuff here
5792                check there too. */
5793             regnode *trie_node= scan;
5794             regnode *tail= regnext(scan);
5795             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5796             SSize_t max1 = 0, min1 = SSize_t_MAX;
5797             regnode_ssc accum;
5798
5799             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5800                 /* Cannot merge strings after this. */
5801                 scan_commit(pRExC_state, data, minlenp, is_inf);
5802             }
5803             if (flags & SCF_DO_STCLASS)
5804                 ssc_init_zero(pRExC_state, &accum);
5805
5806             if (!trie->jump) {
5807                 min1= trie->minlen;
5808                 max1= trie->maxlen;
5809             } else {
5810                 const regnode *nextbranch= NULL;
5811                 U32 word;
5812
5813                 for ( word=1 ; word <= trie->wordcount ; word++)
5814                 {
5815                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5816                     regnode_ssc this_class;
5817
5818                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5819                     if (data) {
5820                         data_fake.whilem_c = data->whilem_c;
5821                         data_fake.last_closep = data->last_closep;
5822                     }
5823                     else
5824                         data_fake.last_closep = &fake;
5825                     data_fake.pos_delta = delta;
5826                     if (flags & SCF_DO_STCLASS) {
5827                         ssc_init(pRExC_state, &this_class);
5828                         data_fake.start_class = &this_class;
5829                         f = SCF_DO_STCLASS_AND;
5830                     }
5831                     if (flags & SCF_WHILEM_VISITED_POS)
5832                         f |= SCF_WHILEM_VISITED_POS;
5833
5834                     if (trie->jump[word]) {
5835                         if (!nextbranch)
5836                             nextbranch = trie_node + trie->jump[0];
5837                         scan= trie_node + trie->jump[word];
5838                         /* We go from the jump point to the branch that follows
5839                            it. Note this means we need the vestigal unused
5840                            branches even though they arent otherwise used. */
5841                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5842                             &deltanext, (regnode *)nextbranch, &data_fake,
5843                             stopparen, recursed_depth, NULL, f,depth+1);
5844                     }
5845                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5846                         nextbranch= regnext((regnode*)nextbranch);
5847
5848                     if (min1 > (SSize_t)(minnext + trie->minlen))
5849                         min1 = minnext + trie->minlen;
5850                     if (deltanext == SSize_t_MAX) {
5851                         is_inf = is_inf_internal = 1;
5852                         max1 = SSize_t_MAX;
5853                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5854                         max1 = minnext + deltanext + trie->maxlen;
5855
5856                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5857                         pars++;
5858                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5859                         if ( stopmin > min + min1)
5860                             stopmin = min + min1;
5861                         flags &= ~SCF_DO_SUBSTR;
5862                         if (data)
5863                             data->flags |= SCF_SEEN_ACCEPT;
5864                     }
5865                     if (data) {
5866                         if (data_fake.flags & SF_HAS_EVAL)
5867                             data->flags |= SF_HAS_EVAL;
5868                         data->whilem_c = data_fake.whilem_c;
5869                     }
5870                     if (flags & SCF_DO_STCLASS)
5871                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5872                 }
5873             }
5874             if (flags & SCF_DO_SUBSTR) {
5875                 data->pos_min += min1;
5876                 data->pos_delta += max1 - min1;
5877                 if (max1 != min1 || is_inf)
5878                     data->longest = &(data->longest_float);
5879             }
5880             min += min1;
5881             if (delta != SSize_t_MAX)
5882                 delta += max1 - min1;
5883             if (flags & SCF_DO_STCLASS_OR) {
5884                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5885                 if (min1) {
5886                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5887                     flags &= ~SCF_DO_STCLASS;
5888                 }
5889             }
5890             else if (flags & SCF_DO_STCLASS_AND) {
5891                 if (min1) {
5892                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5893                     flags &= ~SCF_DO_STCLASS;
5894                 }
5895                 else {
5896                     /* Switch to OR mode: cache the old value of
5897                      * data->start_class */
5898                     INIT_AND_WITHP;
5899                     StructCopy(data->start_class, and_withp, regnode_ssc);
5900                     flags &= ~SCF_DO_STCLASS_AND;
5901                     StructCopy(&accum, data->start_class, regnode_ssc);
5902                     flags |= SCF_DO_STCLASS_OR;
5903                 }
5904             }
5905             scan= tail;
5906             continue;
5907         }
5908 #else
5909         else if (PL_regkind[OP(scan)] == TRIE) {
5910             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5911             U8*bang=NULL;
5912
5913             min += trie->minlen;
5914             delta += (trie->maxlen - trie->minlen);
5915             flags &= ~SCF_DO_STCLASS; /* xxx */
5916             if (flags & SCF_DO_SUBSTR) {
5917                 /* Cannot expect anything... */
5918                 scan_commit(pRExC_state, data, minlenp, is_inf);
5919                 data->pos_min += trie->minlen;
5920                 data->pos_delta += (trie->maxlen - trie->minlen);
5921                 if (trie->maxlen != trie->minlen)
5922                     data->longest = &(data->longest_float);
5923             }
5924             if (trie->jump) /* no more substrings -- for now /grr*/
5925                flags &= ~SCF_DO_SUBSTR;
5926         }
5927 #endif /* old or new */
5928 #endif /* TRIE_STUDY_OPT */
5929
5930         /* Else: zero-length, ignore. */
5931         scan = regnext(scan);
5932     }
5933
5934   finish:
5935     if (frame) {
5936         /* we need to unwind recursion. */
5937         depth = depth - 1;
5938
5939         DEBUG_STUDYDATA("frame-end:",data,depth);
5940         DEBUG_PEEP("fend", scan, depth);
5941
5942         /* restore previous context */
5943         last = frame->last_regnode;
5944         scan = frame->next_regnode;
5945         stopparen = frame->stopparen;
5946         recursed_depth = frame->prev_recursed_depth;
5947
5948         RExC_frame_last = frame->prev_frame;
5949         frame = frame->this_prev_frame;
5950         goto fake_study_recurse;
5951     }
5952
5953     assert(!frame);
5954     DEBUG_STUDYDATA("pre-fin:",data,depth);
5955
5956     *scanp = scan;
5957     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5958
5959     if (flags & SCF_DO_SUBSTR && is_inf)
5960         data->pos_delta = SSize_t_MAX - data->pos_min;
5961     if (is_par > (I32)U8_MAX)
5962         is_par = 0;
5963     if (is_par && pars==1 && data) {
5964         data->flags |= SF_IN_PAR;
5965         data->flags &= ~SF_HAS_PAR;
5966     }
5967     else if (pars && data) {
5968         data->flags |= SF_HAS_PAR;
5969         data->flags &= ~SF_IN_PAR;
5970     }
5971     if (flags & SCF_DO_STCLASS_OR)
5972         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5973     if (flags & SCF_TRIE_RESTUDY)
5974         data->flags |=  SCF_TRIE_RESTUDY;
5975
5976     DEBUG_STUDYDATA("post-fin:",data,depth);
5977
5978     {
5979         SSize_t final_minlen= min < stopmin ? min : stopmin;
5980
5981         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
5982             if (final_minlen > SSize_t_MAX - delta)
5983                 RExC_maxlen = SSize_t_MAX;
5984             else if (RExC_maxlen < final_minlen + delta)
5985                 RExC_maxlen = final_minlen + delta;
5986         }
5987         return final_minlen;
5988     }
5989     NOT_REACHED; /* NOTREACHED */
5990 }
5991
5992 STATIC U32
5993 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5994 {
5995     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5996
5997     PERL_ARGS_ASSERT_ADD_DATA;
5998
5999     Renewc(RExC_rxi->data,
6000            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6001            char, struct reg_data);
6002     if(count)
6003         Renew(RExC_rxi->data->what, count + n, U8);
6004     else
6005         Newx(RExC_rxi->data->what, n, U8);
6006     RExC_rxi->data->count = count + n;
6007     Copy(s, RExC_rxi->data->what + count, n, U8);
6008     return count;
6009 }
6010
6011 /*XXX: todo make this not included in a non debugging perl, but appears to be
6012  * used anyway there, in 'use re' */
6013 #ifndef PERL_IN_XSUB_RE
6014 void
6015 Perl_reginitcolors(pTHX)
6016 {
6017     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6018     if (s) {
6019         char *t = savepv(s);
6020         int i = 0;
6021         PL_colors[0] = t;
6022         while (++i < 6) {
6023             t = strchr(t, '\t');
6024             if (t) {
6025                 *t = '\0';
6026                 PL_colors[i] = ++t;
6027             }
6028             else
6029                 PL_colors[i] = t = (char *)"";
6030         }
6031     } else {
6032         int i = 0;
6033         while (i < 6)
6034             PL_colors[i++] = (char *)"";
6035     }
6036     PL_colorset = 1;
6037 }
6038 #endif
6039
6040
6041 #ifdef TRIE_STUDY_OPT
6042 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6043     STMT_START {                                            \
6044         if (                                                \
6045               (data.flags & SCF_TRIE_RESTUDY)               \
6046               && ! restudied++                              \
6047         ) {                                                 \
6048             dOsomething;                                    \
6049             goto reStudy;                                   \
6050         }                                                   \
6051     } STMT_END
6052 #else
6053 #define CHECK_RESTUDY_GOTO_butfirst
6054 #endif
6055
6056 /*
6057  * pregcomp - compile a regular expression into internal code
6058  *
6059  * Decides which engine's compiler to call based on the hint currently in
6060  * scope
6061  */
6062
6063 #ifndef PERL_IN_XSUB_RE
6064
6065 /* return the currently in-scope regex engine (or the default if none)  */
6066
6067 regexp_engine const *
6068 Perl_current_re_engine(pTHX)
6069 {
6070     if (IN_PERL_COMPILETIME) {
6071         HV * const table = GvHV(PL_hintgv);
6072         SV **ptr;
6073
6074         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6075             return &PL_core_reg_engine;
6076         ptr = hv_fetchs(table, "regcomp", FALSE);
6077         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6078             return &PL_core_reg_engine;
6079         return INT2PTR(regexp_engine*,SvIV(*ptr));
6080     }
6081     else {
6082         SV *ptr;
6083         if (!PL_curcop->cop_hints_hash)
6084             return &PL_core_reg_engine;
6085         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6086         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6087             return &PL_core_reg_engine;
6088         return INT2PTR(regexp_engine*,SvIV(ptr));
6089     }
6090 }
6091
6092
6093 REGEXP *
6094 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6095 {
6096     regexp_engine const *eng = current_re_engine();
6097     GET_RE_DEBUG_FLAGS_DECL;
6098
6099     PERL_ARGS_ASSERT_PREGCOMP;
6100
6101     /* Dispatch a request to compile a regexp to correct regexp engine. */
6102     DEBUG_COMPILE_r({
6103         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6104                         PTR2UV(eng));
6105     });
6106     return CALLREGCOMP_ENG(eng, pattern, flags);
6107 }
6108 #endif
6109
6110 /* public(ish) entry point for the perl core's own regex compiling code.
6111  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6112  * pattern rather than a list of OPs, and uses the internal engine rather
6113  * than the current one */
6114
6115 REGEXP *
6116 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6117 {
6118     SV *pat = pattern; /* defeat constness! */
6119     PERL_ARGS_ASSERT_RE_COMPILE;
6120     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6121 #ifdef PERL_IN_XSUB_RE
6122                                 &my_reg_engine,
6123 #else
6124                                 &PL_core_reg_engine,
6125 #endif
6126                                 NULL, NULL, rx_flags, 0);
6127 }
6128
6129
6130 static void
6131 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6132 {
6133     int n;
6134
6135     if (--cbs->refcnt > 0)
6136         return;
6137     for (n = 0; n < cbs->count; n++) {
6138         REGEXP *rx = cbs->cb[n].src_regex;
6139         cbs->cb[n].src_regex = NULL;
6140         SvREFCNT_dec(rx);
6141     }
6142     Safefree(cbs->cb);
6143     Safefree(cbs);
6144 }
6145
6146
6147 static struct reg_code_blocks *
6148 S_alloc_code_blocks(pTHX_  int ncode)
6149 {
6150      struct reg_code_blocks *cbs;
6151     Newx(cbs, 1, struct reg_code_blocks);
6152     cbs->count = ncode;
6153     cbs->refcnt = 1;
6154     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6155     if (ncode)
6156         Newx(cbs->cb, ncode, struct reg_code_block);
6157     else
6158         cbs->cb = NULL;
6159     return cbs;
6160 }
6161
6162
6163 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6164  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6165  * point to the realloced string and length.
6166  *
6167  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6168  * stuff added */
6169
6170 static void
6171 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6172                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6173 {
6174     U8 *const src = (U8*)*pat_p;
6175     U8 *dst, *d;
6176     int n=0;
6177     STRLEN s = 0;
6178     bool do_end = 0;
6179     GET_RE_DEBUG_FLAGS_DECL;
6180
6181     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6182         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6183
6184     Newx(dst, *plen_p * 2 + 1, U8);
6185     d = dst;
6186
6187     while (s < *plen_p) {
6188         append_utf8_from_native_byte(src[s], &d);
6189
6190         if (n < num_code_blocks) {
6191             assert(pRExC_state->code_blocks);
6192             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6193                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6194                 assert(*(d - 1) == '(');
6195                 do_end = 1;
6196             }
6197             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6198                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6199                 assert(*(d - 1) == ')');
6200                 do_end = 0;
6201                 n++;
6202             }
6203         }
6204         s++;
6205     }
6206     *d = '\0';
6207     *plen_p = d - dst;
6208     *pat_p = (char*) dst;
6209     SAVEFREEPV(*pat_p);
6210     RExC_orig_utf8 = RExC_utf8 = 1;
6211 }
6212
6213
6214
6215 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6216  * while recording any code block indices, and handling overloading,
6217  * nested qr// objects etc.  If pat is null, it will allocate a new
6218  * string, or just return the first arg, if there's only one.
6219  *
6220  * Returns the malloced/updated pat.
6221  * patternp and pat_count is the array of SVs to be concatted;
6222  * oplist is the optional list of ops that generated the SVs;
6223  * recompile_p is a pointer to a boolean that will be set if
6224  *   the regex will need to be recompiled.
6225  * delim, if non-null is an SV that will be inserted between each element
6226  */
6227
6228 static SV*
6229 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6230                 SV *pat, SV ** const patternp, int pat_count,
6231                 OP *oplist, bool *recompile_p, SV *delim)
6232 {
6233     SV **svp;
6234     int n = 0;
6235     bool use_delim = FALSE;
6236     bool alloced = FALSE;
6237
6238     /* if we know we have at least two args, create an empty string,
6239      * then concatenate args to that. For no args, return an empty string */
6240     if (!pat && pat_count != 1) {
6241         pat = newSVpvs("");
6242         SAVEFREESV(pat);
6243         alloced = TRUE;
6244     }
6245
6246     for (svp = patternp; svp < patternp + pat_count; svp++) {
6247         SV *sv;
6248         SV *rx  = NULL;
6249         STRLEN orig_patlen = 0;
6250         bool code = 0;
6251         SV *msv = use_delim ? delim : *svp;
6252         if (!msv) msv = &PL_sv_undef;
6253
6254         /* if we've got a delimiter, we go round the loop twice for each
6255          * svp slot (except the last), using the delimiter the second
6256          * time round */
6257         if (use_delim) {
6258             svp--;
6259             use_delim = FALSE;
6260         }
6261         else if (delim)
6262             use_delim = TRUE;
6263
6264         if (SvTYPE(msv) == SVt_PVAV) {
6265             /* we've encountered an interpolated array within
6266              * the pattern, e.g. /...@a..../. Expand the list of elements,
6267              * then recursively append elements.
6268              * The code in this block is based on S_pushav() */
6269
6270             AV *const av = (AV*)msv;
6271             const SSize_t maxarg = AvFILL(av) + 1;
6272             SV **array;
6273
6274             if (oplist) {
6275                 assert(oplist->op_type == OP_PADAV
6276                     || oplist->op_type == OP_RV2AV);
6277                 oplist = OpSIBLING(oplist);
6278             }
6279
6280             if (SvRMAGICAL(av)) {
6281                 SSize_t i;
6282
6283                 Newx(array, maxarg, SV*);
6284                 SAVEFREEPV(array);
6285                 for (i=0; i < maxarg; i++) {
6286                     SV ** const svp = av_fetch(av, i, FALSE);
6287                     array[i] = svp ? *svp : &PL_sv_undef;
6288                 }
6289             }
6290             else
6291                 array = AvARRAY(av);
6292
6293             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6294                                 array, maxarg, NULL, recompile_p,
6295                                 /* $" */
6296                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6297
6298             continue;
6299         }
6300
6301
6302         /* we make the assumption here that each op in the list of
6303          * op_siblings maps to one SV pushed onto the stack,
6304          * except for code blocks, with have both an OP_NULL and
6305          * and OP_CONST.
6306          * This allows us to match up the list of SVs against the
6307          * list of OPs to find the next code block.
6308          *
6309          * Note that       PUSHMARK PADSV PADSV ..
6310          * is optimised to
6311          *                 PADRANGE PADSV  PADSV  ..
6312          * so the alignment still works. */
6313
6314         if (oplist) {
6315             if (oplist->op_type == OP_NULL
6316                 && (oplist->op_flags & OPf_SPECIAL))
6317             {
6318                 assert(n < pRExC_state->code_blocks->count);
6319                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6320                 pRExC_state->code_blocks->cb[n].block = oplist;
6321                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6322                 n++;
6323                 code = 1;
6324                 oplist = OpSIBLING(oplist); /* skip CONST */
6325                 assert(oplist);
6326             }
6327             oplist = OpSIBLING(oplist);;
6328         }
6329
6330         /* apply magic and QR overloading to arg */
6331
6332         SvGETMAGIC(msv);
6333         if (SvROK(msv) && SvAMAGIC(msv)) {
6334             SV *sv = AMG_CALLunary(msv, regexp_amg);
6335             if (sv) {
6336                 if (SvROK(sv))
6337                     sv = SvRV(sv);
6338                 if (SvTYPE(sv) != SVt_REGEXP)
6339                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6340                 msv = sv;
6341             }
6342         }
6343
6344         /* try concatenation overload ... */
6345         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6346                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6347         {
6348             sv_setsv(pat, sv);
6349             /* overloading involved: all bets are off over literal
6350              * code. Pretend we haven't seen it */
6351             if (n)
6352                 pRExC_state->code_blocks->count -= n;
6353             n = 0;
6354         }
6355         else  {
6356             /* ... or failing that, try "" overload */
6357             while (SvAMAGIC(msv)
6358                     && (sv = AMG_CALLunary(msv, string_amg))
6359                     && sv != msv
6360                     &&  !(   SvROK(msv)
6361                           && SvROK(sv)
6362                           && SvRV(msv) == SvRV(sv))
6363             ) {
6364                 msv = sv;
6365                 SvGETMAGIC(msv);
6366             }
6367             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6368                 msv = SvRV(msv);
6369
6370             if (pat) {
6371                 /* this is a partially unrolled
6372                  *     sv_catsv_nomg(pat, msv);
6373                  * that allows us to adjust code block indices if
6374                  * needed */
6375                 STRLEN dlen;
6376                 char *dst = SvPV_force_nomg(pat, dlen);
6377                 orig_patlen = dlen;
6378                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6379                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6380                     sv_setpvn(pat, dst, dlen);
6381                     SvUTF8_on(pat);
6382                 }
6383                 sv_catsv_nomg(pat, msv);
6384                 rx = msv;
6385             }
6386             else {
6387                 /* We have only one SV to process, but we need to verify
6388                  * it is properly null terminated or we will fail asserts
6389                  * later. In theory we probably shouldn't get such SV's,
6390                  * but if we do we should handle it gracefully. */
6391                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) ) {
6392                     /* not a string, or a string with a trailing null */
6393                     pat = msv;
6394                 } else {
6395                     /* a string with no trailing null, we need to copy it
6396                      * so it we have a trailing null */
6397                     pat = newSVsv(msv);
6398                 }
6399             }
6400
6401             if (code)
6402                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
6403         }
6404
6405         /* extract any code blocks within any embedded qr//'s */
6406         if (rx && SvTYPE(rx) == SVt_REGEXP
6407             && RX_ENGINE((REGEXP*)rx)->op_comp)
6408         {
6409
6410             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6411             if (ri->code_blocks && ri->code_blocks->count) {
6412                 int i;
6413                 /* the presence of an embedded qr// with code means
6414                  * we should always recompile: the text of the
6415                  * qr// may not have changed, but it may be a
6416                  * different closure than last time */
6417                 *recompile_p = 1;
6418                 if (pRExC_state->code_blocks) {
6419                     pRExC_state->code_blocks->count += ri->code_blocks->count;
6420                     Renew(pRExC_state->code_blocks->cb,
6421                             pRExC_state->code_blocks->count,
6422                             struct reg_code_block);
6423                 }
6424                 else
6425                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
6426                                                     ri->code_blocks->count);
6427
6428                 for (i=0; i < ri->code_blocks->count; i++) {
6429                     struct reg_code_block *src, *dst;
6430                     STRLEN offset =  orig_patlen
6431                         + ReANY((REGEXP *)rx)->pre_prefix;
6432                     assert(n < pRExC_state->code_blocks->count);
6433                     src = &ri->code_blocks->cb[i];
6434                     dst = &pRExC_state->code_blocks->cb[n];
6435                     dst->start      = src->start + offset;
6436                     dst->end        = src->end   + offset;
6437                     dst->block      = src->block;
6438                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6439                                             src->src_regex
6440                                                 ? src->src_regex
6441                                                 : (REGEXP*)rx);
6442                     n++;
6443                 }
6444             }
6445         }
6446     }
6447     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6448     if (alloced)
6449         SvSETMAGIC(pat);
6450
6451     return pat;
6452 }
6453
6454
6455
6456 /* see if there are any run-time code blocks in the pattern.
6457  * False positives are allowed */
6458
6459 static bool
6460 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6461                     char *pat, STRLEN plen)
6462 {
6463     int n = 0;
6464     STRLEN s;
6465     
6466     PERL_UNUSED_CONTEXT;
6467
6468     for (s = 0; s < plen; s++) {
6469         if (   pRExC_state->code_blocks
6470             && n < pRExC_state->code_blocks->count
6471             && s == pRExC_state->code_blocks->cb[n].start)
6472         {
6473             s = pRExC_state->code_blocks->cb[n].end;
6474             n++;
6475             continue;
6476         }
6477         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6478          * positives here */
6479         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6480             (pat[s+2] == '{'
6481                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6482         )
6483             return 1;
6484     }
6485     return 0;
6486 }
6487
6488 /* Handle run-time code blocks. We will already have compiled any direct
6489  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6490  * copy of it, but with any literal code blocks blanked out and
6491  * appropriate chars escaped; then feed it into
6492  *
6493  *    eval "qr'modified_pattern'"
6494  *
6495  * For example,
6496  *
6497  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6498  *
6499  * becomes
6500  *
6501  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6502  *
6503  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6504  * and merge them with any code blocks of the original regexp.
6505  *
6506  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6507  * instead, just save the qr and return FALSE; this tells our caller that
6508  * the original pattern needs upgrading to utf8.
6509  */
6510
6511 static bool
6512 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6513     char *pat, STRLEN plen)
6514 {
6515     SV *qr;
6516
6517     GET_RE_DEBUG_FLAGS_DECL;
6518
6519     if (pRExC_state->runtime_code_qr) {
6520         /* this is the second time we've been called; this should
6521          * only happen if the main pattern got upgraded to utf8
6522          * during compilation; re-use the qr we compiled first time
6523          * round (which should be utf8 too)
6524          */
6525         qr = pRExC_state->runtime_code_qr;
6526         pRExC_state->runtime_code_qr = NULL;
6527         assert(RExC_utf8 && SvUTF8(qr));
6528     }
6529     else {
6530         int n = 0;
6531         STRLEN s;
6532         char *p, *newpat;
6533         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
6534         SV *sv, *qr_ref;
6535         dSP;
6536
6537         /* determine how many extra chars we need for ' and \ escaping */
6538         for (s = 0; s < plen; s++) {
6539             if (pat[s] == '\'' || pat[s] == '\\')
6540                 newlen++;
6541         }
6542
6543         Newx(newpat, newlen, char);
6544         p = newpat;
6545         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6546
6547         for (s = 0; s < plen; s++) {
6548             if (   pRExC_state->code_blocks
6549                 && n < pRExC_state->code_blocks->count
6550                 && s == pRExC_state->code_blocks->cb[n].start)
6551             {
6552                 /* blank out literal code block */
6553                 assert(pat[s] == '(');
6554                 while (s <= pRExC_state->code_blocks->cb[n].end) {
6555                     *p++ = '_';
6556                     s++;
6557                 }
6558                 s--;
6559                 n++;
6560                 continue;
6561             }
6562             if (pat[s] == '\'' || pat[s] == '\\')
6563                 *p++ = '\\';
6564             *p++ = pat[s];
6565         }
6566         *p++ = '\'';
6567         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
6568             *p++ = 'x';
6569             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
6570                 *p++ = 'x';
6571             }
6572         }
6573         *p++ = '\0';
6574         DEBUG_COMPILE_r({
6575             Perl_re_printf( aTHX_
6576                 "%sre-parsing pattern for runtime code:%s %s\n",
6577                 PL_colors[4],PL_colors[5],newpat);
6578         });
6579
6580         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6581         Safefree(newpat);
6582
6583         ENTER;
6584         SAVETMPS;
6585         save_re_context();
6586         PUSHSTACKi(PERLSI_REQUIRE);
6587         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6588          * parsing qr''; normally only q'' does this. It also alters
6589          * hints handling */
6590         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6591         SvREFCNT_dec_NN(sv);
6592         SPAGAIN;
6593         qr_ref = POPs;
6594         PUTBACK;
6595         {
6596             SV * const errsv = ERRSV;
6597             if (SvTRUE_NN(errsv))
6598                 /* use croak_sv ? */
6599                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
6600         }
6601         assert(SvROK(qr_ref));
6602         qr = SvRV(qr_ref);
6603         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6604         /* the leaving below frees the tmp qr_ref.
6605          * Give qr a life of its own */
6606         SvREFCNT_inc(qr);
6607         POPSTACK;
6608         FREETMPS;
6609         LEAVE;
6610
6611     }
6612
6613     if (!RExC_utf8 && SvUTF8(qr)) {
6614         /* first time through; the pattern got upgraded; save the
6615          * qr for the next time through */
6616         assert(!pRExC_state->runtime_code_qr);
6617         pRExC_state->runtime_code_qr = qr;
6618         return 0;
6619     }
6620
6621
6622     /* extract any code blocks within the returned qr//  */
6623
6624
6625     /* merge the main (r1) and run-time (r2) code blocks into one */
6626     {
6627         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6628         struct reg_code_block *new_block, *dst;
6629         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6630         int i1 = 0, i2 = 0;
6631         int r1c, r2c;
6632
6633         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
6634         {
6635             SvREFCNT_dec_NN(qr);
6636             return 1;
6637         }
6638
6639         if (!r1->code_blocks)
6640             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
6641
6642         r1c = r1->code_blocks->count;
6643         r2c = r2->code_blocks->count;
6644
6645         Newx(new_block, r1c + r2c, struct reg_code_block);
6646
6647         dst = new_block;
6648
6649         while (i1 < r1c || i2 < r2c) {
6650             struct reg_code_block *src;
6651             bool is_qr = 0;
6652
6653             if (i1 == r1c) {
6654                 src = &r2->code_blocks->cb[i2++];
6655                 is_qr = 1;
6656             }
6657             else if (i2 == r2c)
6658                 src = &r1->code_blocks->cb[i1++];
6659             else if (  r1->code_blocks->cb[i1].start
6660                      < r2->code_blocks->cb[i2].start)
6661             {
6662                 src = &r1->code_blocks->cb[i1++];
6663                 assert(src->end < r2->code_blocks->cb[i2].start);
6664             }
6665             else {
6666                 assert(  r1->code_blocks->cb[i1].start
6667                        > r2->code_blocks->cb[i2].start);
6668                 src = &r2->code_blocks->cb[i2++];
6669                 is_qr = 1;
6670                 assert(src->end < r1->code_blocks->cb[i1].start);
6671             }
6672
6673             assert(pat[src->start] == '(');
6674             assert(pat[src->end]   == ')');
6675             dst->start      = src->start;
6676             dst->end        = src->end;
6677             dst->block      = src->block;
6678             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6679                                     : src->src_regex;
6680             dst++;
6681         }
6682         r1->code_blocks->count += r2c;
6683         Safefree(r1->code_blocks->cb);
6684         r1->code_blocks->cb = new_block;
6685     }
6686
6687     SvREFCNT_dec_NN(qr);
6688     return 1;
6689 }
6690
6691
6692 STATIC bool
6693 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6694                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6695                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6696                       STRLEN longest_length, bool eol, bool meol)
6697 {
6698     /* This is the common code for setting up the floating and fixed length
6699      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6700      * as to whether succeeded or not */
6701
6702     I32 t;
6703     SSize_t ml;
6704
6705     if (! (longest_length
6706            || (eol /* Can't have SEOL and MULTI */
6707                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6708           )
6709             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6710         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6711     {
6712         return FALSE;
6713     }
6714
6715     /* copy the information about the longest from the reg_scan_data
6716         over to the program. */
6717     if (SvUTF8(sv_longest)) {
6718         *rx_utf8 = sv_longest;
6719         *rx_substr = NULL;
6720     } else {
6721         *rx_substr = sv_longest;
6722         *rx_utf8 = NULL;
6723     }
6724     /* end_shift is how many chars that must be matched that
6725         follow this item. We calculate it ahead of time as once the
6726         lookbehind offset is added in we lose the ability to correctly
6727         calculate it.*/
6728     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6729     *rx_end_shift = ml - offset
6730         - longest_length
6731             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
6732              * intead? - DAPM
6733             + (SvTAIL(sv_longest) != 0)
6734             */
6735         + lookbehind;
6736
6737     t = (eol/* Can't have SEOL and MULTI */
6738          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6739     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6740
6741     return TRUE;
6742 }
6743
6744 /*
6745  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6746  * regular expression into internal code.
6747  * The pattern may be passed either as:
6748  *    a list of SVs (patternp plus pat_count)
6749  *    a list of OPs (expr)
6750  * If both are passed, the SV list is used, but the OP list indicates
6751  * which SVs are actually pre-compiled code blocks
6752  *
6753  * The SVs in the list have magic and qr overloading applied to them (and
6754  * the list may be modified in-place with replacement SVs in the latter
6755  * case).
6756  *
6757  * If the pattern hasn't changed from old_re, then old_re will be
6758  * returned.
6759  *
6760  * eng is the current engine. If that engine has an op_comp method, then
6761  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6762  * do the initial concatenation of arguments and pass on to the external
6763  * engine.
6764  *
6765  * If is_bare_re is not null, set it to a boolean indicating whether the
6766  * arg list reduced (after overloading) to a single bare regex which has
6767  * been returned (i.e. /$qr/).
6768  *
6769  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6770  *
6771  * pm_flags contains the PMf_* flags, typically based on those from the
6772  * pm_flags field of the related PMOP. Currently we're only interested in
6773  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6774  *
6775  * We can't allocate space until we know how big the compiled form will be,
6776  * but we can't compile it (and thus know how big it is) until we've got a
6777  * place to put the code.  So we cheat:  we compile it twice, once with code
6778  * generation turned off and size counting turned on, and once "for real".
6779  * This also means that we don't allocate space until we are sure that the
6780  * thing really will compile successfully, and we never have to move the
6781  * code and thus invalidate pointers into it.  (Note that it has to be in
6782  * one piece because free() must be able to free it all.) [NB: not true in perl]
6783  *
6784  * Beware that the optimization-preparation code in here knows about some
6785  * of the structure of the compiled regexp.  [I'll say.]
6786  */
6787
6788 REGEXP *
6789 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6790                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6791                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6792 {
6793     REGEXP *rx;
6794     struct regexp *r;
6795     regexp_internal *ri;
6796     STRLEN plen;
6797     char *exp;
6798     regnode *scan;
6799     I32 flags;
6800     SSize_t minlen = 0;
6801     U32 rx_flags;
6802     SV *pat;
6803     SV** new_patternp = patternp;
6804
6805     /* these are all flags - maybe they should be turned
6806      * into a single int with different bit masks */
6807     I32 sawlookahead = 0;
6808     I32 sawplus = 0;
6809     I32 sawopen = 0;
6810     I32 sawminmod = 0;
6811
6812     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6813     bool recompile = 0;
6814     bool runtime_code = 0;
6815     scan_data_t data;
6816     RExC_state_t RExC_state;
6817     RExC_state_t * const pRExC_state = &RExC_state;
6818 #ifdef TRIE_STUDY_OPT
6819     int restudied = 0;
6820     RExC_state_t copyRExC_state;
6821 #endif
6822     GET_RE_DEBUG_FLAGS_DECL;
6823
6824     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6825
6826     DEBUG_r(if (!PL_colorset) reginitcolors());
6827
6828     /* Initialize these here instead of as-needed, as is quick and avoids
6829      * having to test them each time otherwise */
6830     if (! PL_AboveLatin1) {
6831 #ifdef DEBUGGING
6832         char * dump_len_string;
6833 #endif
6834
6835         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6836         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6837         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6838         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6839         PL_HasMultiCharFold =
6840                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6841
6842         /* This is calculated here, because the Perl program that generates the
6843          * static global ones doesn't currently have access to
6844          * NUM_ANYOF_CODE_POINTS */
6845         PL_InBitmap = _new_invlist(2);
6846         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6847                                                     NUM_ANYOF_CODE_POINTS - 1);
6848 #ifdef DEBUGGING
6849         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6850         if (   ! dump_len_string
6851             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6852         {
6853             PL_dump_re_max_len = 0;
6854         }
6855 #endif
6856     }
6857
6858     pRExC_state->warn_text = NULL;
6859     pRExC_state->code_blocks = NULL;
6860
6861     if (is_bare_re)
6862         *is_bare_re = FALSE;
6863
6864     if (expr && (expr->op_type == OP_LIST ||
6865                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6866         /* allocate code_blocks if needed */
6867         OP *o;
6868         int ncode = 0;
6869
6870         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6871             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6872                 ncode++; /* count of DO blocks */
6873
6874         if (ncode)
6875             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
6876     }
6877
6878     if (!pat_count) {
6879         /* compile-time pattern with just OP_CONSTs and DO blocks */
6880
6881         int n;
6882         OP *o;
6883
6884         /* find how many CONSTs there are */
6885         assert(expr);
6886         n = 0;
6887         if (expr->op_type == OP_CONST)
6888             n = 1;
6889         else
6890             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6891                 if (o->op_type == OP_CONST)
6892                     n++;
6893             }
6894
6895         /* fake up an SV array */
6896
6897         assert(!new_patternp);
6898         Newx(new_patternp, n, SV*);
6899         SAVEFREEPV(new_patternp);
6900         pat_count = n;
6901
6902         n = 0;
6903         if (expr->op_type == OP_CONST)
6904             new_patternp[n] = cSVOPx_sv(expr);
6905         else
6906             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6907                 if (o->op_type == OP_CONST)
6908                     new_patternp[n++] = cSVOPo_sv;
6909             }
6910
6911     }
6912
6913     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6914         "Assembling pattern from %d elements%s\n", pat_count,
6915             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6916
6917     /* set expr to the first arg op */
6918
6919     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
6920          && expr->op_type != OP_CONST)
6921     {
6922             expr = cLISTOPx(expr)->op_first;
6923             assert(   expr->op_type == OP_PUSHMARK
6924                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6925                    || expr->op_type == OP_PADRANGE);
6926             expr = OpSIBLING(expr);
6927     }
6928
6929     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6930                         expr, &recompile, NULL);
6931
6932     /* handle bare (possibly after overloading) regex: foo =~ $re */
6933     {
6934         SV *re = pat;
6935         if (SvROK(re))
6936             re = SvRV(re);
6937         if (SvTYPE(re) == SVt_REGEXP) {
6938             if (is_bare_re)
6939                 *is_bare_re = TRUE;
6940             SvREFCNT_inc(re);
6941             DEBUG_PARSE_r(Perl_re_printf( aTHX_
6942                 "Precompiled pattern%s\n",
6943                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6944
6945             return (REGEXP*)re;
6946         }
6947     }
6948
6949     exp = SvPV_nomg(pat, plen);
6950
6951     if (!eng->op_comp) {
6952         if ((SvUTF8(pat) && IN_BYTES)
6953                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6954         {
6955             /* make a temporary copy; either to convert to bytes,
6956              * or to avoid repeating get-magic / overloaded stringify */
6957             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6958                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6959         }
6960         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6961     }
6962
6963     /* ignore the utf8ness if the pattern is 0 length */
6964     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6965
6966     RExC_uni_semantics = 0;
6967     RExC_seen_unfolded_sharp_s = 0;
6968     RExC_contains_locale = 0;
6969     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
6970     RExC_study_started = 0;
6971     pRExC_state->runtime_code_qr = NULL;
6972     RExC_frame_head= NULL;
6973     RExC_frame_last= NULL;
6974     RExC_frame_count= 0;
6975
6976     DEBUG_r({
6977         RExC_mysv1= sv_newmortal();
6978         RExC_mysv2= sv_newmortal();
6979     });
6980     DEBUG_COMPILE_r({
6981             SV *dsv= sv_newmortal();
6982             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6983             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
6984                           PL_colors[4],PL_colors[5],s);
6985         });
6986
6987   redo_first_pass:
6988     /* we jump here if we have to recompile, e.g., from upgrading the pattern
6989      * to utf8 */
6990
6991     if ((pm_flags & PMf_USE_RE_EVAL)
6992                 /* this second condition covers the non-regex literal case,
6993                  * i.e.  $foo =~ '(?{})'. */
6994                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6995     )
6996         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6997
6998     /* return old regex if pattern hasn't changed */
6999     /* XXX: note in the below we have to check the flags as well as the
7000      * pattern.
7001      *
7002      * Things get a touch tricky as we have to compare the utf8 flag
7003      * independently from the compile flags.  */
7004
7005     if (   old_re
7006         && !recompile
7007         && !!RX_UTF8(old_re) == !!RExC_utf8
7008         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7009         && RX_PRECOMP(old_re)
7010         && RX_PRELEN(old_re) == plen
7011         && memEQ(RX_PRECOMP(old_re), exp, plen)
7012         && !runtime_code /* with runtime code, always recompile */ )
7013     {
7014         return old_re;
7015     }
7016
7017     rx_flags = orig_rx_flags;
7018
7019     if (   initial_charset == REGEX_DEPENDS_CHARSET
7020         && (RExC_utf8 ||RExC_uni_semantics))
7021     {
7022
7023         /* Set to use unicode semantics if the pattern is in utf8 and has the
7024          * 'depends' charset specified, as it means unicode when utf8  */
7025         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7026     }
7027
7028     RExC_precomp = exp;
7029     RExC_precomp_adj = 0;
7030     RExC_flags = rx_flags;
7031     RExC_pm_flags = pm_flags;
7032
7033     if (runtime_code) {
7034         assert(TAINTING_get || !TAINT_get);
7035         if (TAINT_get)
7036             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7037
7038         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7039             /* whoops, we have a non-utf8 pattern, whilst run-time code
7040              * got compiled as utf8. Try again with a utf8 pattern */
7041             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7042                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7043             goto redo_first_pass;
7044         }
7045     }
7046     assert(!pRExC_state->runtime_code_qr);
7047
7048     RExC_sawback = 0;
7049
7050     RExC_seen = 0;
7051     RExC_maxlen = 0;
7052     RExC_in_lookbehind = 0;
7053     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7054     RExC_extralen = 0;
7055 #ifdef EBCDIC
7056     RExC_recode_x_to_native = 0;
7057 #endif
7058     RExC_in_multi_char_class = 0;
7059
7060     /* First pass: determine size, legality. */
7061     RExC_parse = exp;
7062     RExC_start = RExC_adjusted_start = exp;
7063     RExC_end = exp + plen;
7064     RExC_precomp_end = RExC_end;
7065     RExC_naughty = 0;
7066     RExC_npar = 1;
7067     RExC_nestroot = 0;
7068     RExC_size = 0L;
7069     RExC_emit = (regnode *) &RExC_emit_dummy;
7070     RExC_whilem_seen = 0;
7071     RExC_open_parens = NULL;
7072     RExC_close_parens = NULL;
7073     RExC_end_op = NULL;
7074     RExC_paren_names = NULL;
7075 #ifdef DEBUGGING
7076     RExC_paren_name_list = NULL;
7077 #endif
7078     RExC_recurse = NULL;
7079     RExC_study_chunk_recursed = NULL;
7080     RExC_study_chunk_recursed_bytes= 0;
7081     RExC_recurse_count = 0;
7082     pRExC_state->code_index = 0;
7083
7084     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7085      * code makes sure the final byte is an uncounted NUL.  But should this
7086      * ever not be the case, lots of things could read beyond the end of the
7087      * buffer: loops like
7088      *      while(isFOO(*RExC_parse)) RExC_parse++;
7089      *      strchr(RExC_parse, "foo");
7090      * etc.  So it is worth noting. */
7091     assert(*RExC_end == '\0');
7092
7093     DEBUG_PARSE_r(
7094         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7095         RExC_lastnum=0;
7096         RExC_lastparse=NULL;
7097     );
7098
7099     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7100         /* It's possible to write a regexp in ascii that represents Unicode
7101         codepoints outside of the byte range, such as via \x{100}. If we
7102         detect such a sequence we have to convert the entire pattern to utf8
7103         and then recompile, as our sizing calculation will have been based
7104         on 1 byte == 1 character, but we will need to use utf8 to encode
7105         at least some part of the pattern, and therefore must convert the whole
7106         thing.
7107         -- dmq */
7108         if (flags & RESTART_PASS1) {
7109             if (flags & NEED_UTF8) {
7110                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7111                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7112             }
7113             else {
7114                 DEBUG_PARSE_r(Perl_re_printf( aTHX_
7115                 "Need to redo pass 1\n"));
7116             }
7117
7118             goto redo_first_pass;
7119         }
7120         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
7121     }
7122
7123     DEBUG_PARSE_r({
7124         Perl_re_printf( aTHX_
7125             "Required size %" IVdf " nodes\n"
7126             "Starting second pass (creation)\n",
7127             (IV)RExC_size);
7128         RExC_lastnum=0;
7129         RExC_lastparse=NULL;
7130     });
7131
7132     /* The first pass could have found things that force Unicode semantics */
7133     if ((RExC_utf8 || RExC_uni_semantics)
7134          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7135     {
7136         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7137     }
7138
7139     /* Small enough for pointer-storage convention?
7140        If extralen==0, this means that we will not need long jumps. */
7141     if (RExC_size >= 0x10000L && RExC_extralen)
7142         RExC_size += RExC_extralen;
7143     else
7144         RExC_extralen = 0;
7145     if (RExC_whilem_seen > 15)
7146         RExC_whilem_seen = 15;
7147
7148     /* Allocate space and zero-initialize. Note, the two step process
7149        of zeroing when in debug mode, thus anything assigned has to
7150        happen after that */
7151     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7152     r = ReANY(rx);
7153     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7154          char, regexp_internal);
7155     if ( r == NULL || ri == NULL )
7156         FAIL("Regexp out of space");
7157 #ifdef DEBUGGING
7158     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7159     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7160          char);
7161 #else
7162     /* bulk initialize base fields with 0. */
7163     Zero(ri, sizeof(regexp_internal), char);
7164 #endif
7165
7166     /* non-zero initialization begins here */
7167     RXi_SET( r, ri );
7168     r->engine= eng;
7169     r->extflags = rx_flags;
7170     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7171
7172     if (pm_flags & PMf_IS_QR) {
7173         ri->code_blocks = pRExC_state->code_blocks;
7174         if (ri->code_blocks)
7175             ri->code_blocks->refcnt++;
7176     }
7177
7178     {
7179         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7180         bool has_charset = (get_regex_charset(r->extflags)
7181                                                     != REGEX_DEPENDS_CHARSET);
7182
7183         /* The caret is output if there are any defaults: if not all the STD
7184          * flags are set, or if no character set specifier is needed */
7185         bool has_default =
7186                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7187                     || ! has_charset);
7188         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7189                                                    == REG_RUN_ON_COMMENT_SEEN);
7190         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7191                             >> RXf_PMf_STD_PMMOD_SHIFT);
7192         const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7193         char *p;
7194
7195         /* We output all the necessary flags; we never output a minus, as all
7196          * those are defaults, so are
7197          * covered by the caret */
7198         const STRLEN wraplen = plen + has_p + has_runon
7199             + has_default       /* If needs a caret */
7200             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7201
7202                 /* If needs a character set specifier */
7203             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7204             + (sizeof("(?:)") - 1);
7205
7206         /* make sure PL_bitcount bounds not exceeded */
7207         assert(sizeof(STD_PAT_MODS) <= 8);
7208
7209         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
7210         r->xpv_len_u.xpvlenu_pv = p;
7211         if (RExC_utf8)
7212             SvFLAGS(rx) |= SVf_UTF8;
7213         *p++='('; *p++='?';
7214
7215         /* If a default, cover it using the caret */
7216         if (has_default) {
7217             *p++= DEFAULT_PAT_MOD;
7218         }
7219         if (has_charset) {
7220             STRLEN len;
7221             const char* const name = get_regex_charset_name(r->extflags, &len);
7222             Copy(name, p, len, char);
7223             p += len;
7224         }
7225         if (has_p)
7226             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7227         {
7228             char ch;
7229             while((ch = *fptr++)) {
7230                 if(reganch & 1)
7231                     *p++ = ch;
7232                 reganch >>= 1;
7233             }
7234         }
7235
7236         *p++ = ':';
7237         Copy(RExC_precomp, p, plen, char);
7238         assert ((RX_WRAPPED(rx) - p) < 16);
7239         r->pre_prefix = p - RX_WRAPPED(rx);
7240         p += plen;
7241         if (has_runon)
7242             *p++ = '\n';
7243         *p++ = ')';
7244         *p = 0;
7245         SvCUR_set(rx, p - RX_WRAPPED(rx));
7246     }
7247
7248     r->intflags = 0;
7249     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7250
7251     /* Useful during FAIL. */
7252 #ifdef RE_TRACK_PATTERN_OFFSETS
7253     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7254     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7255                           "%s %" UVuf " bytes for offset annotations.\n",
7256                           ri->u.offsets ? "Got" : "Couldn't get",
7257                           (UV)((2*RExC_size+1) * sizeof(U32))));
7258 #endif
7259     SetProgLen(ri,RExC_size);
7260     RExC_rx_sv = rx;
7261     RExC_rx = r;
7262     RExC_rxi = ri;
7263
7264     /* Second pass: emit code. */
7265     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7266     RExC_pm_flags = pm_flags;
7267     RExC_parse = exp;
7268     RExC_end = exp + plen;
7269     RExC_naughty = 0;
7270     RExC_emit_start = ri->program;
7271     RExC_emit = ri->program;
7272     RExC_emit_bound = ri->program + RExC_size + 1;
7273     pRExC_state->code_index = 0;
7274
7275     *((char*) RExC_emit++) = (char) REG_MAGIC;
7276     /* setup various meta data about recursion, this all requires
7277      * RExC_npar to be correctly set, and a bit later on we clear it */
7278     if (RExC_seen & REG_RECURSE_SEEN) {
7279         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7280             "%*s%*s Setting up open/close parens\n",
7281                   22, "|    |", (int)(0 * 2 + 1), ""));
7282
7283         /* setup RExC_open_parens, which holds the address of each
7284          * OPEN tag, and to make things simpler for the 0 index
7285          * the start of the program - this is used later for offsets */
7286         Newxz(RExC_open_parens, RExC_npar,regnode *);
7287         SAVEFREEPV(RExC_open_parens);
7288         RExC_open_parens[0] = RExC_emit;
7289
7290         /* setup RExC_close_parens, which holds the address of each
7291          * CLOSE tag, and to make things simpler for the 0 index
7292          * the end of the program - this is used later for offsets */
7293         Newxz(RExC_close_parens, RExC_npar,regnode *);
7294         SAVEFREEPV(RExC_close_parens);
7295         /* we dont know where end op starts yet, so we dont
7296          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7297
7298         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7299          * So its 1 if there are no parens. */
7300         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7301                                          ((RExC_npar & 0x07) != 0);
7302         Newx(RExC_study_chunk_recursed,
7303              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7304         SAVEFREEPV(RExC_study_chunk_recursed);
7305     }
7306     RExC_npar = 1;
7307     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7308         ReREFCNT_dec(rx);
7309         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#" UVxf, (UV) flags);
7310     }
7311     DEBUG_OPTIMISE_r(
7312         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7313     );
7314
7315     /* XXXX To minimize changes to RE engine we always allocate
7316        3-units-long substrs field. */
7317     Newx(r->substrs, 1, struct reg_substr_data);
7318     if (RExC_recurse_count) {
7319         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
7320         SAVEFREEPV(RExC_recurse);
7321     }
7322
7323   reStudy:
7324     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7325     DEBUG_r(
7326         RExC_study_chunk_recursed_count= 0;
7327     );
7328     Zero(r->substrs, 1, struct reg_substr_data);
7329     if (RExC_study_chunk_recursed) {
7330         Zero(RExC_study_chunk_recursed,
7331              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7332     }
7333
7334
7335 #ifdef TRIE_STUDY_OPT
7336     if (!restudied) {
7337         StructCopy(&zero_scan_data, &data, scan_data_t);
7338         copyRExC_state = RExC_state;
7339     } else {
7340         U32 seen=RExC_seen;
7341         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7342
7343         RExC_state = copyRExC_state;
7344         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7345             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7346         else
7347             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7348         StructCopy(&zero_scan_data, &data, scan_data_t);
7349     }
7350 #else
7351     StructCopy(&zero_scan_data, &data, scan_data_t);
7352 #endif
7353
7354     /* Dig out information for optimizations. */
7355     r->extflags = RExC_flags; /* was pm_op */
7356     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7357
7358     if (UTF)
7359         SvUTF8_on(rx);  /* Unicode in it? */
7360     ri->regstclass = NULL;
7361     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7362         r->intflags |= PREGf_NAUGHTY;
7363     scan = ri->program + 1;             /* First BRANCH. */
7364
7365     /* testing for BRANCH here tells us whether there is "must appear"
7366        data in the pattern. If there is then we can use it for optimisations */
7367     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7368                                                   */
7369         SSize_t fake;
7370         STRLEN longest_float_length, longest_fixed_length;
7371         regnode_ssc ch_class; /* pointed to by data */
7372         int stclass_flag;
7373         SSize_t last_close = 0; /* pointed to by data */
7374         regnode *first= scan;
7375         regnode *first_next= regnext(first);
7376         /*
7377          * Skip introductions and multiplicators >= 1
7378          * so that we can extract the 'meat' of the pattern that must
7379          * match in the large if() sequence following.
7380          * NOTE that EXACT is NOT covered here, as it is normally
7381          * picked up by the optimiser separately.
7382          *
7383          * This is unfortunate as the optimiser isnt handling lookahead
7384          * properly currently.
7385          *
7386          */
7387         while ((OP(first) == OPEN && (sawopen = 1)) ||
7388                /* An OR of *one* alternative - should not happen now. */
7389             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7390             /* for now we can't handle lookbehind IFMATCH*/
7391             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7392             (OP(first) == PLUS) ||
7393             (OP(first) == MINMOD) ||
7394                /* An {n,m} with n>0 */
7395             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7396             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7397         {
7398                 /*
7399                  * the only op that could be a regnode is PLUS, all the rest
7400                  * will be regnode_1 or regnode_2.
7401                  *
7402                  * (yves doesn't think this is true)
7403                  */
7404                 if (OP(first) == PLUS)
7405                     sawplus = 1;
7406                 else {
7407                     if (OP(first) == MINMOD)
7408                         sawminmod = 1;
7409                     first += regarglen[OP(first)];
7410                 }
7411                 first = NEXTOPER(first);
7412                 first_next= regnext(first);
7413         }
7414
7415         /* Starting-point info. */
7416       again:
7417         DEBUG_PEEP("first:",first,0);
7418         /* Ignore EXACT as we deal with it later. */
7419         if (PL_regkind[OP(first)] == EXACT) {
7420             if (OP(first) == EXACT || OP(first) == EXACTL)
7421                 NOOP;   /* Empty, get anchored substr later. */
7422             else
7423                 ri->regstclass = first;
7424         }
7425 #ifdef TRIE_STCLASS
7426         else if (PL_regkind[OP(first)] == TRIE &&
7427                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7428         {
7429             /* this can happen only on restudy */
7430             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7431         }
7432 #endif
7433         else if (REGNODE_SIMPLE(OP(first)))
7434             ri->regstclass = first;
7435         else if (PL_regkind[OP(first)] == BOUND ||
7436                  PL_regkind[OP(first)] == NBOUND)
7437             ri->regstclass = first;
7438         else if (PL_regkind[OP(first)] == BOL) {
7439             r->intflags |= (OP(first) == MBOL
7440                            ? PREGf_ANCH_MBOL
7441                            : PREGf_ANCH_SBOL);
7442             first = NEXTOPER(first);
7443             goto again;
7444         }
7445         else if (OP(first) == GPOS) {
7446             r->intflags |= PREGf_ANCH_GPOS;
7447             first = NEXTOPER(first);
7448             goto again;
7449         }
7450         else if ((!sawopen || !RExC_sawback) &&
7451             !sawlookahead &&
7452             (OP(first) == STAR &&
7453             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7454             !(r->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
7455         {
7456             /* turn .* into ^.* with an implied $*=1 */
7457             const int type =
7458                 (OP(NEXTOPER(first)) == REG_ANY)
7459                     ? PREGf_ANCH_MBOL
7460                     : PREGf_ANCH_SBOL;
7461             r->intflags |= (type | PREGf_IMPLICIT);
7462             first = NEXTOPER(first);
7463             goto again;
7464         }
7465         if (sawplus && !sawminmod && !sawlookahead
7466             && (!sawopen || !RExC_sawback)
7467             && !pRExC_state->code_blocks) /* May examine pos and $& */
7468             /* x+ must match at the 1st pos of run of x's */
7469             r->intflags |= PREGf_SKIP;
7470
7471         /* Scan is after the zeroth branch, first is atomic matcher. */
7472 #ifdef TRIE_STUDY_OPT
7473         DEBUG_PARSE_r(
7474             if (!restudied)
7475                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7476                               (IV)(first - scan + 1))
7477         );
7478 #else
7479         DEBUG_PARSE_r(
7480             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7481                 (IV)(first - scan + 1))
7482         );
7483 #endif
7484
7485
7486         /*
7487         * If there's something expensive in the r.e., find the
7488         * longest literal string that must appear and make it the
7489         * regmust.  Resolve ties in favor of later strings, since
7490         * the regstart check works with the beginning of the r.e.
7491         * and avoiding duplication strengthens checking.  Not a
7492         * strong reason, but sufficient in the absence of others.
7493         * [Now we resolve ties in favor of the earlier string if
7494         * it happens that c_offset_min has been invalidated, since the
7495         * earlier string may buy us something the later one won't.]
7496         */
7497
7498         data.longest_fixed = newSVpvs("");
7499         data.longest_float = newSVpvs("");
7500         data.last_found = newSVpvs("");
7501         data.longest = &(data.longest_fixed);
7502         ENTER_with_name("study_chunk");
7503         SAVEFREESV(data.longest_fixed);
7504         SAVEFREESV(data.longest_float);
7505         SAVEFREESV(data.last_found);
7506         first = scan;
7507         if (!ri->regstclass) {
7508             ssc_init(pRExC_state, &ch_class);
7509             data.start_class = &ch_class;
7510             stclass_flag = SCF_DO_STCLASS_AND;
7511         } else                          /* XXXX Check for BOUND? */
7512             stclass_flag = 0;
7513         data.last_closep = &last_close;
7514
7515         DEBUG_RExC_seen();
7516         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7517                              scan + RExC_size, /* Up to end */
7518             &data, -1, 0, NULL,
7519             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7520                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7521             0);
7522
7523
7524         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7525
7526
7527         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
7528              && data.last_start_min == 0 && data.last_end > 0
7529              && !RExC_seen_zerolen
7530              && !(RExC_seen & REG_VERBARG_SEEN)
7531              && !(RExC_seen & REG_GPOS_SEEN)
7532         ){
7533             r->extflags |= RXf_CHECK_ALL;
7534         }
7535         scan_commit(pRExC_state, &data,&minlen,0);
7536
7537         longest_float_length = CHR_SVLEN(data.longest_float);
7538
7539         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
7540                    && data.offset_fixed == data.offset_float_min
7541                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
7542             && S_setup_longest (aTHX_ pRExC_state,
7543                                     data.longest_float,
7544                                     &(r->float_utf8),
7545                                     &(r->float_substr),
7546                                     &(r->float_end_shift),
7547                                     data.lookbehind_float,
7548                                     data.offset_float_min,
7549                                     data.minlen_float,
7550                                     longest_float_length,
7551                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
7552                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
7553         {
7554             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
7555             r->float_max_offset = data.offset_float_max;
7556             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
7557                 r->float_max_offset -= data.lookbehind_float;
7558             SvREFCNT_inc_simple_void_NN(data.longest_float);
7559         }
7560         else {
7561             r->float_substr = r->float_utf8 = NULL;
7562             longest_float_length = 0;
7563         }
7564
7565         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
7566
7567         if (S_setup_longest (aTHX_ pRExC_state,
7568                                 data.longest_fixed,
7569                                 &(r->anchored_utf8),
7570                                 &(r->anchored_substr),
7571                                 &(r->anchored_end_shift),
7572                                 data.lookbehind_fixed,
7573                                 data.offset_fixed,
7574                                 data.minlen_fixed,
7575                                 longest_fixed_length,
7576                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7577                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7578         {
7579             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7580             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7581         }
7582         else {
7583             r->anchored_substr = r->anchored_utf8 = NULL;
7584             longest_fixed_length = 0;
7585         }
7586         LEAVE_with_name("study_chunk");
7587
7588         if (ri->regstclass
7589             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7590             ri->regstclass = NULL;
7591
7592         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7593             && stclass_flag
7594             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7595             && is_ssc_worth_it(pRExC_state, data.start_class))
7596         {
7597             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7598
7599             ssc_finalize(pRExC_state, data.start_class);
7600
7601             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7602             StructCopy(data.start_class,
7603                        (regnode_ssc*)RExC_rxi->data->data[n],
7604                        regnode_ssc);
7605             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7606             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7607             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7608                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7609                       Perl_re_printf( aTHX_
7610                                     "synthetic stclass \"%s\".\n",
7611                                     SvPVX_const(sv));});
7612             data.start_class = NULL;
7613         }
7614
7615         /* A temporary algorithm prefers floated substr to fixed one to dig
7616          * more info. */
7617         if (longest_fixed_length > longest_float_length) {
7618             r->substrs->check_ix = 0;
7619             r->check_end_shift = r->anchored_end_shift;
7620             r->check_substr = r->anchored_substr;
7621             r->check_utf8 = r->anchored_utf8;
7622             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7623             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7624                 r->intflags |= PREGf_NOSCAN;
7625         }
7626         else {
7627             r->substrs->check_ix = 1;
7628             r->check_end_shift = r->float_end_shift;
7629             r->check_substr = r->float_substr;
7630             r->check_utf8 = r->float_utf8;
7631             r->check_offset_min = r->float_min_offset;
7632             r->check_offset_max = r->float_max_offset;
7633         }
7634         if ((r->check_substr || r->check_utf8) ) {
7635             r->extflags |= RXf_USE_INTUIT;
7636             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7637                 r->extflags |= RXf_INTUIT_TAIL;
7638         }
7639         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7640
7641         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7642         if ( (STRLEN)minlen < longest_float_length )
7643             minlen= longest_float_length;
7644         if ( (STRLEN)minlen < longest_fixed_length )
7645             minlen= longest_fixed_length;
7646         */
7647     }
7648     else {
7649         /* Several toplevels. Best we can is to set minlen. */
7650         SSize_t fake;
7651         regnode_ssc ch_class;
7652         SSize_t last_close = 0;
7653
7654         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7655
7656         scan = ri->program + 1;
7657         ssc_init(pRExC_state, &ch_class);
7658         data.start_class = &ch_class;
7659         data.last_closep = &last_close;
7660
7661         DEBUG_RExC_seen();
7662         minlen = study_chunk(pRExC_state,
7663             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7664             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7665                                                       ? SCF_TRIE_DOING_RESTUDY
7666                                                       : 0),
7667             0);
7668
7669         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7670
7671         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7672                 = r->float_substr = r->float_utf8 = NULL;
7673
7674         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7675             && is_ssc_worth_it(pRExC_state, data.start_class))
7676         {
7677             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7678
7679             ssc_finalize(pRExC_state, data.start_class);
7680
7681             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7682             StructCopy(data.start_class,
7683                        (regnode_ssc*)RExC_rxi->data->data[n],
7684                        regnode_ssc);
7685             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7686             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7687             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7688                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7689                       Perl_re_printf( aTHX_
7690                                     "synthetic stclass \"%s\".\n",
7691                                     SvPVX_const(sv));});
7692             data.start_class = NULL;
7693         }
7694     }
7695
7696     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7697         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7698         r->maxlen = REG_INFTY;
7699     }
7700     else {
7701         r->maxlen = RExC_maxlen;
7702     }
7703
7704     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7705        the "real" pattern. */
7706     DEBUG_OPTIMISE_r({
7707         Perl_re_printf( aTHX_ "minlen: %" IVdf " r->minlen:%" IVdf " maxlen:%" IVdf "\n",
7708                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7709     });
7710     r->minlenret = minlen;
7711     if (r->minlen < minlen)
7712         r->minlen = minlen;
7713
7714     if (RExC_seen & REG_RECURSE_SEEN ) {
7715         r->intflags |= PREGf_RECURSE_SEEN;
7716         Newxz(r->recurse_locinput, r->nparens + 1, char *);
7717     }
7718     if (RExC_seen & REG_GPOS_SEEN)
7719         r->intflags |= PREGf_GPOS_SEEN;
7720     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7721         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7722                                                 lookbehind */
7723     if (pRExC_state->code_blocks)
7724         r->extflags |= RXf_EVAL_SEEN;
7725     if (RExC_seen & REG_VERBARG_SEEN)
7726     {
7727         r->intflags |= PREGf_VERBARG_SEEN;
7728         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7729     }
7730     if (RExC_seen & REG_CUTGROUP_SEEN)
7731         r->intflags |= PREGf_CUTGROUP_SEEN;
7732     if (pm_flags & PMf_USE_RE_EVAL)
7733         r->intflags |= PREGf_USE_RE_EVAL;
7734     if (RExC_paren_names)
7735         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7736     else
7737         RXp_PAREN_NAMES(r) = NULL;
7738
7739     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7740      * so it can be used in pp.c */
7741     if (r->intflags & PREGf_ANCH)
7742         r->extflags |= RXf_IS_ANCHORED;
7743
7744
7745     {
7746         /* this is used to identify "special" patterns that might result
7747          * in Perl NOT calling the regex engine and instead doing the match "itself",
7748          * particularly special cases in split//. By having the regex compiler
7749          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7750          * we avoid weird issues with equivalent patterns resulting in different behavior,
7751          * AND we allow non Perl engines to get the same optimizations by the setting the
7752          * flags appropriately - Yves */
7753         regnode *first = ri->program + 1;
7754         U8 fop = OP(first);
7755         regnode *next = regnext(first);
7756         U8 nop = OP(next);
7757
7758         if (PL_regkind[fop] == NOTHING && nop == END)
7759             r->extflags |= RXf_NULL;
7760         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7761             /* when fop is SBOL first->flags will be true only when it was
7762              * produced by parsing /\A/, and not when parsing /^/. This is
7763              * very important for the split code as there we want to
7764              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7765              * See rt #122761 for more details. -- Yves */
7766             r->extflags |= RXf_START_ONLY;
7767         else if (fop == PLUS
7768                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7769                  && nop == END)
7770             r->extflags |= RXf_WHITE;
7771         else if ( r->extflags & RXf_SPLIT
7772                   && (fop == EXACT || fop == EXACTL)
7773                   && STR_LEN(first) == 1
7774                   && *(STRING(first)) == ' '
7775                   && nop == END )
7776             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7777
7778     }
7779
7780     if (RExC_contains_locale) {
7781         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7782     }
7783
7784 #ifdef DEBUGGING
7785     if (RExC_paren_names) {
7786         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7787         ri->data->data[ri->name_list_idx]
7788                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7789     } else
7790 #endif
7791     ri->name_list_idx = 0;
7792
7793     while ( RExC_recurse_count > 0 ) {
7794         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7795         /*
7796          * This data structure is set up in study_chunk() and is used
7797          * to calculate the distance between a GOSUB regopcode and
7798          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
7799          * it refers to.
7800          *
7801          * If for some reason someone writes code that optimises
7802          * away a GOSUB opcode then the assert should be changed to
7803          * an if(scan) to guard the ARG2L_SET() - Yves
7804          *
7805          */
7806         assert(scan && OP(scan) == GOSUB);
7807         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7808     }
7809
7810     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7811     /* assume we don't need to swap parens around before we match */
7812     DEBUG_TEST_r({
7813         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7814             (unsigned long)RExC_study_chunk_recursed_count);
7815     });
7816     DEBUG_DUMP_r({
7817         DEBUG_RExC_seen();
7818         Perl_re_printf( aTHX_ "Final program:\n");
7819         regdump(r);
7820     });
7821 #ifdef RE_TRACK_PATTERN_OFFSETS
7822     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7823         const STRLEN len = ri->u.offsets[0];
7824         STRLEN i;
7825         GET_RE_DEBUG_FLAGS_DECL;
7826         Perl_re_printf( aTHX_
7827                       "Offsets: [%" UVuf "]\n\t", (UV)ri->u.offsets[0]);
7828         for (i = 1; i <= len; i++) {
7829             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7830                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7831                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7832             }
7833         Perl_re_printf( aTHX_  "\n");
7834     });
7835 #endif
7836
7837 #ifdef USE_ITHREADS
7838     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7839      * by setting the regexp SV to readonly-only instead. If the
7840      * pattern's been recompiled, the USEDness should remain. */
7841     if (old_re && SvREADONLY(old_re))
7842         SvREADONLY_on(rx);
7843 #endif
7844     return rx;
7845 }
7846
7847
7848 SV*
7849 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7850                     const U32 flags)
7851 {
7852     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7853
7854     PERL_UNUSED_ARG(value);
7855
7856     if (flags & RXapif_FETCH) {
7857         return reg_named_buff_fetch(rx, key, flags);
7858     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7859         Perl_croak_no_modify();
7860         return NULL;
7861     } else if (flags & RXapif_EXISTS) {
7862         return reg_named_buff_exists(rx, key, flags)
7863             ? &PL_sv_yes
7864             : &PL_sv_no;
7865     } else if (flags & RXapif_REGNAMES) {
7866         return reg_named_buff_all(rx, flags);
7867     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7868         return reg_named_buff_scalar(rx, flags);
7869     } else {
7870         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7871         return NULL;
7872     }
7873 }
7874
7875 SV*
7876 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7877                          const U32 flags)
7878 {
7879     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7880     PERL_UNUSED_ARG(lastkey);
7881
7882     if (flags & RXapif_FIRSTKEY)
7883         return reg_named_buff_firstkey(rx, flags);
7884     else if (flags & RXapif_NEXTKEY)
7885         return reg_named_buff_nextkey(rx, flags);
7886     else {
7887         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7888                                             (int)flags);
7889         return NULL;
7890     }
7891 }
7892
7893 SV*
7894 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7895                           const U32 flags)
7896 {
7897     AV *retarray = NULL;
7898     SV *ret;
7899     struct regexp *const rx = ReANY(r);
7900
7901     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7902
7903     if (flags & RXapif_ALL)
7904         retarray=newAV();
7905
7906     if (rx && RXp_PAREN_NAMES(rx)) {
7907         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7908         if (he_str) {
7909             IV i;
7910             SV* sv_dat=HeVAL(he_str);
7911             I32 *nums=(I32*)SvPVX(sv_dat);
7912             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7913                 if ((I32)(rx->nparens) >= nums[i]
7914                     && rx->offs[nums[i]].start != -1
7915                     && rx->offs[nums[i]].end != -1)
7916                 {
7917                     ret = newSVpvs("");
7918                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7919                     if (!retarray)
7920                         return ret;
7921                 } else {
7922                     if (retarray)
7923                         ret = newSVsv(&PL_sv_undef);
7924                 }
7925                 if (retarray)
7926                     av_push(retarray, ret);
7927             }
7928             if (retarray)
7929                 return newRV_noinc(MUTABLE_SV(retarray));
7930         }
7931     }
7932     return NULL;
7933 }
7934
7935 bool
7936 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7937                            const U32 flags)
7938 {
7939     struct regexp *const rx = ReANY(r);
7940
7941     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7942
7943     if (rx && RXp_PAREN_NAMES(rx)) {
7944         if (flags & RXapif_ALL) {
7945             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7946         } else {
7947             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7948             if (sv) {
7949                 SvREFCNT_dec_NN(sv);
7950                 return TRUE;
7951             } else {
7952                 return FALSE;
7953             }
7954         }
7955     } else {
7956         return FALSE;
7957     }
7958 }
7959
7960 SV*
7961 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7962 {
7963     struct regexp *const rx = ReANY(r);
7964
7965     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7966
7967     if ( rx && RXp_PAREN_NAMES(rx) ) {
7968         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7969
7970         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7971     } else {
7972         return FALSE;
7973     }
7974 }
7975
7976 SV*
7977 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7978 {
7979     struct regexp *const rx = ReANY(r);
7980     GET_RE_DEBUG_FLAGS_DECL;
7981
7982     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7983
7984     if (rx && RXp_PAREN_NAMES(rx)) {
7985         HV *hv = RXp_PAREN_NAMES(rx);
7986         HE *temphe;
7987         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7988             IV i;
7989             IV parno = 0;
7990             SV* sv_dat = HeVAL(temphe);
7991             I32 *nums = (I32*)SvPVX(sv_dat);
7992             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7993                 if ((I32)(rx->lastparen) >= nums[i] &&
7994                     rx->offs[nums[i]].start != -1 &&
7995                     rx->offs[nums[i]].end != -1)
7996                 {
7997                     parno = nums[i];
7998                     break;
7999                 }
8000             }
8001             if (parno || flags & RXapif_ALL) {
8002                 return newSVhek(HeKEY_hek(temphe));
8003             }
8004         }
8005     }
8006     return NULL;
8007 }
8008
8009 SV*
8010 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8011 {
8012     SV *ret;
8013     AV *av;
8014     SSize_t length;
8015     struct regexp *const rx = ReANY(r);
8016
8017     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8018
8019     if (rx && RXp_PAREN_NAMES(rx)) {
8020         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8021             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8022         } else if (flags & RXapif_ONE) {
8023             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8024             av = MUTABLE_AV(SvRV(ret));
8025             length = av_tindex(av);
8026             SvREFCNT_dec_NN(ret);
8027             return newSViv(length + 1);
8028         } else {
8029             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8030                                                 (int)flags);
8031             return NULL;
8032         }
8033     }
8034     return &PL_sv_undef;
8035 }
8036
8037 SV*
8038 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8039 {
8040     struct regexp *const rx = ReANY(r);
8041     AV *av = newAV();
8042
8043     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8044
8045     if (rx && RXp_PAREN_NAMES(rx)) {
8046         HV *hv= RXp_PAREN_NAMES(rx);
8047         HE *temphe;
8048         (void)hv_iterinit(hv);
8049         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8050             IV i;
8051             IV parno = 0;
8052             SV* sv_dat = HeVAL(temphe);
8053             I32 *nums = (I32*)SvPVX(sv_dat);
8054             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8055                 if ((I32)(rx->lastparen) >= nums[i] &&
8056                     rx->offs[nums[i]].start != -1 &&
8057                     rx->offs[nums[i]].end != -1)
8058                 {
8059                     parno = nums[i];
8060                     break;
8061                 }
8062             }
8063             if (parno || flags & RXapif_ALL) {
8064                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8065             }
8066         }
8067     }
8068
8069     return newRV_noinc(MUTABLE_SV(av));
8070 }
8071
8072 void
8073 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8074                              SV * const sv)
8075 {
8076     struct regexp *const rx = ReANY(r);
8077     char *s = NULL;
8078     SSize_t i = 0;
8079     SSize_t s1, t1;
8080     I32 n = paren;
8081
8082     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8083
8084     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8085            || n == RX_BUFF_IDX_CARET_FULLMATCH
8086            || n == RX_BUFF_IDX_CARET_POSTMATCH
8087        )
8088     {
8089         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8090         if (!keepcopy) {
8091             /* on something like
8092              *    $r = qr/.../;
8093              *    /$qr/p;
8094              * the KEEPCOPY is set on the PMOP rather than the regex */
8095             if (PL_curpm && r == PM_GETRE(PL_curpm))
8096                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8097         }
8098         if (!keepcopy)
8099             goto ret_undef;
8100     }
8101
8102     if (!rx->subbeg)
8103         goto ret_undef;
8104
8105     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8106         /* no need to distinguish between them any more */
8107         n = RX_BUFF_IDX_FULLMATCH;
8108
8109     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8110         && rx->offs[0].start != -1)
8111     {
8112         /* $`, ${^PREMATCH} */
8113         i = rx->offs[0].start;
8114         s = rx->subbeg;
8115     }
8116     else
8117     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8118         && rx->offs[0].end != -1)
8119     {
8120         /* $', ${^POSTMATCH} */
8121         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8122         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8123     }
8124     else
8125     if ( 0 <= n && n <= (I32)rx->nparens &&
8126         (s1 = rx->offs[n].start) != -1 &&
8127         (t1 = rx->offs[n].end) != -1)
8128     {
8129         /* $&, ${^MATCH},  $1 ... */
8130         i = t1 - s1;
8131         s = rx->subbeg + s1 - rx->suboffset;
8132     } else {
8133         goto ret_undef;
8134     }
8135
8136     assert(s >= rx->subbeg);
8137     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8138     if (i >= 0) {
8139 #ifdef NO_TAINT_SUPPORT
8140         sv_setpvn(sv, s, i);
8141 #else
8142         const int oldtainted = TAINT_get;
8143         TAINT_NOT;
8144         sv_setpvn(sv, s, i);
8145         TAINT_set(oldtainted);
8146 #endif
8147         if (RXp_MATCH_UTF8(rx))
8148             SvUTF8_on(sv);
8149         else
8150             SvUTF8_off(sv);
8151         if (TAINTING_get) {
8152             if (RXp_MATCH_TAINTED(rx)) {
8153                 if (SvTYPE(sv) >= SVt_PVMG) {
8154                     MAGIC* const mg = SvMAGIC(sv);
8155                     MAGIC* mgt;
8156                     TAINT;
8157                     SvMAGIC_set(sv, mg->mg_moremagic);
8158                     SvTAINT(sv);
8159                     if ((mgt = SvMAGIC(sv))) {
8160                         mg->mg_moremagic = mgt;
8161                         SvMAGIC_set(sv, mg);
8162                     }
8163                 } else {
8164                     TAINT;
8165                     SvTAINT(sv);
8166                 }
8167             } else
8168                 SvTAINTED_off(sv);
8169         }
8170     } else {
8171       ret_undef:
8172         sv_set_undef(sv);
8173         return;
8174     }
8175 }
8176
8177 void
8178 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8179                                                          SV const * const value)
8180 {
8181     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8182
8183     PERL_UNUSED_ARG(rx);
8184     PERL_UNUSED_ARG(paren);
8185     PERL_UNUSED_ARG(value);
8186
8187     if (!PL_localizing)
8188         Perl_croak_no_modify();
8189 }
8190
8191 I32
8192 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8193                               const I32 paren)
8194 {
8195     struct regexp *const rx = ReANY(r);
8196     I32 i;
8197     I32 s1, t1;
8198
8199     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8200
8201     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8202         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8203         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8204     )
8205     {
8206         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8207         if (!keepcopy) {
8208             /* on something like
8209              *    $r = qr/.../;
8210              *    /$qr/p;
8211              * the KEEPCOPY is set on the PMOP rather than the regex */
8212             if (PL_curpm && r == PM_GETRE(PL_curpm))
8213                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8214         }
8215         if (!keepcopy)
8216             goto warn_undef;
8217     }
8218
8219     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8220     switch (paren) {
8221       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8222       case RX_BUFF_IDX_PREMATCH:       /* $` */
8223         if (rx->offs[0].start != -1) {
8224                         i = rx->offs[0].start;
8225                         if (i > 0) {
8226                                 s1 = 0;
8227                                 t1 = i;
8228                                 goto getlen;
8229                         }
8230             }
8231         return 0;
8232
8233       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8234       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8235             if (rx->offs[0].end != -1) {
8236                         i = rx->sublen - rx->offs[0].end;
8237                         if (i > 0) {
8238                                 s1 = rx->offs[0].end;
8239                                 t1 = rx->sublen;
8240                                 goto getlen;
8241                         }
8242             }
8243         return 0;
8244
8245       default: /* $& / ${^MATCH}, $1, $2, ... */
8246             if (paren <= (I32)rx->nparens &&
8247             (s1 = rx->offs[paren].start) != -1 &&
8248             (t1 = rx->offs[paren].end) != -1)
8249             {
8250             i = t1 - s1;
8251             goto getlen;
8252         } else {
8253           warn_undef:
8254             if (ckWARN(WARN_UNINITIALIZED))
8255                 report_uninit((const SV *)sv);
8256             return 0;
8257         }
8258     }
8259   getlen:
8260     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8261         const char * const s = rx->subbeg - rx->suboffset + s1;
8262         const U8 *ep;
8263         STRLEN el;
8264
8265         i = t1 - s1;
8266         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8267                         i = el;
8268     }
8269     return i;
8270 }
8271
8272 SV*
8273 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8274 {
8275     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8276         PERL_UNUSED_ARG(rx);
8277         if (0)
8278             return NULL;
8279         else
8280             return newSVpvs("Regexp");
8281 }
8282
8283 /* Scans the name of a named buffer from the pattern.
8284  * If flags is REG_RSN_RETURN_NULL returns null.
8285  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8286  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8287  * to the parsed name as looked up in the RExC_paren_names hash.
8288  * If there is an error throws a vFAIL().. type exception.
8289  */
8290
8291 #define REG_RSN_RETURN_NULL    0
8292 #define REG_RSN_RETURN_NAME    1
8293 #define REG_RSN_RETURN_DATA    2
8294
8295 STATIC SV*
8296 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8297 {
8298     char *name_start = RExC_parse;
8299
8300     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8301
8302     assert (RExC_parse <= RExC_end);
8303     if (RExC_parse == RExC_end) NOOP;
8304     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8305          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8306           * using do...while */
8307         if (UTF)
8308             do {
8309                 RExC_parse += UTF8SKIP(RExC_parse);
8310             } while (   RExC_parse < RExC_end
8311                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8312         else
8313             do {
8314                 RExC_parse++;
8315             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8316     } else {
8317         RExC_parse++; /* so the <- from the vFAIL is after the offending
8318                          character */
8319         vFAIL("Group name must start with a non-digit word character");
8320     }
8321     if ( flags ) {
8322         SV* sv_name
8323             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8324                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8325         if ( flags == REG_RSN_RETURN_NAME)
8326             return sv_name;
8327         else if (flags==REG_RSN_RETURN_DATA) {
8328             HE *he_str = NULL;
8329             SV *sv_dat = NULL;
8330             if ( ! sv_name )      /* should not happen*/
8331                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8332             if (RExC_paren_names)
8333                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8334             if ( he_str )
8335                 sv_dat = HeVAL(he_str);
8336             if ( ! sv_dat )
8337                 vFAIL("Reference to nonexistent named group");
8338             return sv_dat;
8339         }
8340         else {
8341             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8342                        (unsigned long) flags);
8343         }
8344         NOT_REACHED; /* NOTREACHED */
8345     }
8346     return NULL;
8347 }
8348
8349 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8350     int num;                                                    \
8351     if (RExC_lastparse!=RExC_parse) {                           \
8352         Perl_re_printf( aTHX_  "%s",                                        \
8353             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8354                 RExC_end - RExC_parse, 16,                      \
8355                 "", "",                                         \
8356                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8357                 PERL_PV_PRETTY_ELLIPSES   |                     \
8358                 PERL_PV_PRETTY_LTGT       |                     \
8359                 PERL_PV_ESCAPE_RE         |                     \
8360                 PERL_PV_PRETTY_EXACTSIZE                        \
8361             )                                                   \
8362         );                                                      \
8363     } else                                                      \
8364         Perl_re_printf( aTHX_ "%16s","");                                   \
8365                                                                 \
8366     if (SIZE_ONLY)                                              \
8367        num = RExC_size + 1;                                     \
8368     else                                                        \
8369        num=REG_NODE_NUM(RExC_emit);                             \
8370     if (RExC_lastnum!=num)                                      \
8371        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8372     else                                                        \
8373        Perl_re_printf( aTHX_ "|%4s","");                                    \
8374     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8375         (int)((depth*2)), "",                                   \
8376         (funcname)                                              \
8377     );                                                          \
8378     RExC_lastnum=num;                                           \
8379     RExC_lastparse=RExC_parse;                                  \
8380 })
8381
8382
8383
8384 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8385     DEBUG_PARSE_MSG((funcname));                            \
8386     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8387 })
8388 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8389     DEBUG_PARSE_MSG((funcname));                            \
8390     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8391 })
8392
8393 /* This section of code defines the inversion list object and its methods.  The
8394  * interfaces are highly subject to change, so as much as possible is static to
8395  * this file.  An inversion list is here implemented as a malloc'd C UV array
8396  * as an SVt_INVLIST scalar.
8397  *
8398  * An inversion list for Unicode is an array of code points, sorted by ordinal
8399  * number.  Each element gives the code point that begins a range that extends
8400  * up-to but not including the code point given by the next element.  The final
8401  * element gives the first code point of a range that extends to the platform's
8402  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8403  * ...) give ranges whose code points are all in the inversion list.  We say
8404  * that those ranges are in the set.  The odd-numbered elements give ranges
8405  * whose code points are not in the inversion list, and hence not in the set.
8406  * Thus, element [0] is the first code point in the list.  Element [1]
8407  * is the first code point beyond that not in the list; and element [2] is the
8408  * first code point beyond that that is in the list.  In other words, the first
8409  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8410  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8411  * all code points in that range are not in the inversion list.  The third
8412  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8413  * list, and so forth.  Thus every element whose index is divisible by two
8414  * gives the beginning of a range that is in the list, and every element whose
8415  * index is not divisible by two gives the beginning of a range not in the
8416  * list.  If the final element's index is divisible by two, the inversion list
8417  * extends to the platform's infinity; otherwise the highest code point in the
8418  * inversion list is the contents of that element minus 1.
8419  *
8420  * A range that contains just a single code point N will look like
8421  *  invlist[i]   == N
8422  *  invlist[i+1] == N+1
8423  *
8424  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8425  * impossible to represent, so element [i+1] is omitted.  The single element
8426  * inversion list
8427  *  invlist[0] == UV_MAX
8428  * contains just UV_MAX, but is interpreted as matching to infinity.
8429  *
8430  * Taking the complement (inverting) an inversion list is quite simple, if the
8431  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8432  * This implementation reserves an element at the beginning of each inversion
8433  * list to always contain 0; there is an additional flag in the header which
8434  * indicates if the list begins at the 0, or is offset to begin at the next
8435  * element.  This means that the inversion list can be inverted without any
8436  * copying; just flip the flag.
8437  *
8438  * More about inversion lists can be found in "Unicode Demystified"
8439  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8440  *
8441  * The inversion list data structure is currently implemented as an SV pointing
8442  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8443  * array of UV whose memory management is automatically handled by the existing
8444  * facilities for SV's.
8445  *
8446  * Some of the methods should always be private to the implementation, and some
8447  * should eventually be made public */
8448
8449 /* The header definitions are in F<invlist_inline.h> */
8450
8451 #ifndef PERL_IN_XSUB_RE
8452
8453 PERL_STATIC_INLINE UV*
8454 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8455 {
8456     /* Returns a pointer to the first element in the inversion list's array.
8457      * This is called upon initialization of an inversion list.  Where the
8458      * array begins depends on whether the list has the code point U+0000 in it
8459      * or not.  The other parameter tells it whether the code that follows this
8460      * call is about to put a 0 in the inversion list or not.  The first
8461      * element is either the element reserved for 0, if TRUE, or the element
8462      * after it, if FALSE */
8463
8464     bool* offset = get_invlist_offset_addr(invlist);
8465     UV* zero_addr = (UV *) SvPVX(invlist);
8466
8467     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8468
8469     /* Must be empty */
8470     assert(! _invlist_len(invlist));
8471
8472     *zero_addr = 0;
8473
8474     /* 1^1 = 0; 1^0 = 1 */
8475     *offset = 1 ^ will_have_0;
8476     return zero_addr + *offset;
8477 }
8478
8479 #endif
8480
8481 PERL_STATIC_INLINE void
8482 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8483 {
8484     /* Sets the current number of elements stored in the inversion list.
8485      * Updates SvCUR correspondingly */
8486     PERL_UNUSED_CONTEXT;
8487     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8488
8489     assert(SvTYPE(invlist) == SVt_INVLIST);
8490
8491     SvCUR_set(invlist,
8492               (len == 0)
8493                ? 0
8494                : TO_INTERNAL_SIZE(len + offset));
8495     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8496 }
8497
8498 #ifndef PERL_IN_XSUB_RE
8499
8500 STATIC void
8501 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8502 {
8503     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
8504      * steals the list from 'src', so 'src' is made to have a NULL list.  This
8505      * is similar to what SvSetMagicSV() would do, if it were implemented on
8506      * inversion lists, though this routine avoids a copy */
8507
8508     const UV src_len          = _invlist_len(src);
8509     const bool src_offset     = *get_invlist_offset_addr(src);
8510     const STRLEN src_byte_len = SvLEN(src);
8511     char * array              = SvPVX(src);
8512
8513     const int oldtainted = TAINT_get;
8514
8515     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8516
8517     assert(SvTYPE(src) == SVt_INVLIST);
8518     assert(SvTYPE(dest) == SVt_INVLIST);
8519     assert(! invlist_is_iterating(src));
8520     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8521
8522     /* Make sure it ends in the right place with a NUL, as our inversion list
8523      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8524      * asserts it */
8525     array[src_byte_len - 1] = '\0';
8526
8527     TAINT_NOT;      /* Otherwise it breaks */
8528     sv_usepvn_flags(dest,
8529                     (char *) array,
8530                     src_byte_len - 1,
8531
8532                     /* This flag is documented to cause a copy to be avoided */
8533                     SV_HAS_TRAILING_NUL);
8534     TAINT_set(oldtainted);
8535     SvPV_set(src, 0);
8536     SvLEN_set(src, 0);
8537     SvCUR_set(src, 0);
8538
8539     /* Finish up copying over the other fields in an inversion list */
8540     *get_invlist_offset_addr(dest) = src_offset;
8541     invlist_set_len(dest, src_len, src_offset);
8542     *get_invlist_previous_index_addr(dest) = 0;
8543     invlist_iterfinish(dest);
8544 }
8545
8546 PERL_STATIC_INLINE IV*
8547 S_get_invlist_previous_index_addr(SV* invlist)
8548 {
8549     /* Return the address of the IV that is reserved to hold the cached index
8550      * */
8551     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8552
8553     assert(SvTYPE(invlist) == SVt_INVLIST);
8554
8555     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8556 }
8557
8558 PERL_STATIC_INLINE IV
8559 S_invlist_previous_index(SV* const invlist)
8560 {
8561     /* Returns cached index of previous search */
8562
8563     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8564
8565     return *get_invlist_previous_index_addr(invlist);
8566 }
8567
8568 PERL_STATIC_INLINE void
8569 S_invlist_set_previous_index(SV* const invlist, const IV index)
8570 {
8571     /* Caches <index> for later retrieval */
8572
8573     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8574
8575     assert(index == 0 || index < (int) _invlist_len(invlist));
8576
8577     *get_invlist_previous_index_addr(invlist) = index;
8578 }
8579
8580 PERL_STATIC_INLINE void
8581 S_invlist_trim(SV* invlist)
8582 {
8583     /* Free the not currently-being-used space in an inversion list */
8584
8585     /* But don't free up the space needed for the 0 UV that is always at the
8586      * beginning of the list, nor the trailing NUL */
8587     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8588
8589     PERL_ARGS_ASSERT_INVLIST_TRIM;
8590
8591     assert(SvTYPE(invlist) == SVt_INVLIST);
8592
8593     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8594 }
8595
8596 PERL_STATIC_INLINE void
8597 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8598 {
8599     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8600
8601     assert(SvTYPE(invlist) == SVt_INVLIST);
8602
8603     invlist_set_len(invlist, 0, 0);
8604     invlist_trim(invlist);
8605 }
8606
8607 #endif /* ifndef PERL_IN_XSUB_RE */
8608
8609 PERL_STATIC_INLINE bool
8610 S_invlist_is_iterating(SV* const invlist)
8611 {
8612     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8613
8614     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8615 }
8616
8617 #ifndef PERL_IN_XSUB_RE
8618
8619 PERL_STATIC_INLINE UV
8620 S_invlist_max(SV* const invlist)
8621 {
8622     /* Returns the maximum number of elements storable in the inversion list's
8623      * array, without having to realloc() */
8624
8625     PERL_ARGS_ASSERT_INVLIST_MAX;
8626
8627     assert(SvTYPE(invlist) == SVt_INVLIST);
8628
8629     /* Assumes worst case, in which the 0 element is not counted in the
8630      * inversion list, so subtracts 1 for that */
8631     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8632            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8633            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8634 }
8635 SV*
8636 Perl__new_invlist(pTHX_ IV initial_size)
8637 {
8638
8639     /* Return a pointer to a newly constructed inversion list, with enough
8640      * space to store 'initial_size' elements.  If that number is negative, a
8641      * system default is used instead */
8642
8643     SV* new_list;
8644
8645     if (initial_size < 0) {
8646         initial_size = 10;
8647     }
8648
8649     /* Allocate the initial space */
8650     new_list = newSV_type(SVt_INVLIST);
8651
8652     /* First 1 is in case the zero element isn't in the list; second 1 is for
8653      * trailing NUL */
8654     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8655     invlist_set_len(new_list, 0, 0);
8656
8657     /* Force iterinit() to be used to get iteration to work */
8658     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8659
8660     *get_invlist_previous_index_addr(new_list) = 0;
8661
8662     return new_list;
8663 }
8664
8665 SV*
8666 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8667 {
8668     /* Return a pointer to a newly constructed inversion list, initialized to
8669      * point to <list>, which has to be in the exact correct inversion list
8670      * form, including internal fields.  Thus this is a dangerous routine that
8671      * should not be used in the wrong hands.  The passed in 'list' contains
8672      * several header fields at the beginning that are not part of the
8673      * inversion list body proper */
8674
8675     const STRLEN length = (STRLEN) list[0];
8676     const UV version_id =          list[1];
8677     const bool offset   =    cBOOL(list[2]);
8678 #define HEADER_LENGTH 3
8679     /* If any of the above changes in any way, you must change HEADER_LENGTH
8680      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8681      *      perl -E 'say int(rand 2**31-1)'
8682      */
8683 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8684                                         data structure type, so that one being
8685                                         passed in can be validated to be an
8686                                         inversion list of the correct vintage.
8687                                        */
8688
8689     SV* invlist = newSV_type(SVt_INVLIST);
8690
8691     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8692
8693     if (version_id != INVLIST_VERSION_ID) {
8694         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8695     }
8696
8697     /* The generated array passed in includes header elements that aren't part
8698      * of the list proper, so start it just after them */
8699     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8700
8701     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8702                                shouldn't touch it */
8703
8704     *(get_invlist_offset_addr(invlist)) = offset;
8705
8706     /* The 'length' passed to us is the physical number of elements in the
8707      * inversion list.  But if there is an offset the logical number is one
8708      * less than that */
8709     invlist_set_len(invlist, length  - offset, offset);
8710
8711     invlist_set_previous_index(invlist, 0);
8712
8713     /* Initialize the iteration pointer. */
8714     invlist_iterfinish(invlist);
8715
8716     SvREADONLY_on(invlist);
8717
8718     return invlist;
8719 }
8720
8721 STATIC void
8722 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8723 {
8724     /* Grow the maximum size of an inversion list */
8725
8726     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8727
8728     assert(SvTYPE(invlist) == SVt_INVLIST);
8729
8730     /* Add one to account for the zero element at the beginning which may not
8731      * be counted by the calling parameters */
8732     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8733 }
8734
8735 STATIC void
8736 S__append_range_to_invlist(pTHX_ SV* const invlist,
8737                                  const UV start, const UV end)
8738 {
8739    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8740     * the end of the inversion list.  The range must be above any existing
8741     * ones. */
8742
8743     UV* array;
8744     UV max = invlist_max(invlist);
8745     UV len = _invlist_len(invlist);
8746     bool offset;
8747
8748     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8749
8750     if (len == 0) { /* Empty lists must be initialized */
8751         offset = start != 0;
8752         array = _invlist_array_init(invlist, ! offset);
8753     }
8754     else {
8755         /* Here, the existing list is non-empty. The current max entry in the
8756          * list is generally the first value not in the set, except when the
8757          * set extends to the end of permissible values, in which case it is
8758          * the first entry in that final set, and so this call is an attempt to
8759          * append out-of-order */
8760
8761         UV final_element = len - 1;
8762         array = invlist_array(invlist);
8763         if (   array[final_element] > start
8764             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8765         {
8766             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",
8767                      array[final_element], start,
8768                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8769         }
8770
8771         /* Here, it is a legal append.  If the new range begins 1 above the end
8772          * of the range below it, it is extending the range below it, so the
8773          * new first value not in the set is one greater than the newly
8774          * extended range.  */
8775         offset = *get_invlist_offset_addr(invlist);
8776         if (array[final_element] == start) {
8777             if (end != UV_MAX) {
8778                 array[final_element] = end + 1;
8779             }
8780             else {
8781                 /* But if the end is the maximum representable on the machine,
8782                  * assume that infinity was actually what was meant.  Just let
8783                  * the range that this would extend to have no end */
8784                 invlist_set_len(invlist, len - 1, offset);
8785             }
8786             return;
8787         }
8788     }
8789
8790     /* Here the new range doesn't extend any existing set.  Add it */
8791
8792     len += 2;   /* Includes an element each for the start and end of range */
8793
8794     /* If wll overflow the existing space, extend, which may cause the array to
8795      * be moved */
8796     if (max < len) {
8797         invlist_extend(invlist, len);
8798
8799         /* Have to set len here to avoid assert failure in invlist_array() */
8800         invlist_set_len(invlist, len, offset);
8801
8802         array = invlist_array(invlist);
8803     }
8804     else {
8805         invlist_set_len(invlist, len, offset);
8806     }
8807
8808     /* The next item on the list starts the range, the one after that is
8809      * one past the new range.  */
8810     array[len - 2] = start;
8811     if (end != UV_MAX) {
8812         array[len - 1] = end + 1;
8813     }
8814     else {
8815         /* But if the end is the maximum representable on the machine, just let
8816          * the range have no end */
8817         invlist_set_len(invlist, len - 1, offset);
8818     }
8819 }
8820
8821 SSize_t
8822 Perl__invlist_search(SV* const invlist, const UV cp)
8823 {
8824     /* Searches the inversion list for the entry that contains the input code
8825      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8826      * return value is the index into the list's array of the range that
8827      * contains <cp>, that is, 'i' such that
8828      *  array[i] <= cp < array[i+1]
8829      */
8830
8831     IV low = 0;
8832     IV mid;
8833     IV high = _invlist_len(invlist);
8834     const IV highest_element = high - 1;
8835     const UV* array;
8836
8837     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8838
8839     /* If list is empty, return failure. */
8840     if (high == 0) {
8841         return -1;
8842     }
8843
8844     /* (We can't get the array unless we know the list is non-empty) */
8845     array = invlist_array(invlist);
8846
8847     mid = invlist_previous_index(invlist);
8848     assert(mid >=0);
8849     if (mid > highest_element) {
8850         mid = highest_element;
8851     }
8852
8853     /* <mid> contains the cache of the result of the previous call to this
8854      * function (0 the first time).  See if this call is for the same result,
8855      * or if it is for mid-1.  This is under the theory that calls to this
8856      * function will often be for related code points that are near each other.
8857      * And benchmarks show that caching gives better results.  We also test
8858      * here if the code point is within the bounds of the list.  These tests
8859      * replace others that would have had to be made anyway to make sure that
8860      * the array bounds were not exceeded, and these give us extra information
8861      * at the same time */
8862     if (cp >= array[mid]) {
8863         if (cp >= array[highest_element]) {
8864             return highest_element;
8865         }
8866
8867         /* Here, array[mid] <= cp < array[highest_element].  This means that
8868          * the final element is not the answer, so can exclude it; it also
8869          * means that <mid> is not the final element, so can refer to 'mid + 1'
8870          * safely */
8871         if (cp < array[mid + 1]) {
8872             return mid;
8873         }
8874         high--;
8875         low = mid + 1;
8876     }
8877     else { /* cp < aray[mid] */
8878         if (cp < array[0]) { /* Fail if outside the array */
8879             return -1;
8880         }
8881         high = mid;
8882         if (cp >= array[mid - 1]) {
8883             goto found_entry;
8884         }
8885     }
8886
8887     /* Binary search.  What we are looking for is <i> such that
8888      *  array[i] <= cp < array[i+1]
8889      * The loop below converges on the i+1.  Note that there may not be an
8890      * (i+1)th element in the array, and things work nonetheless */
8891     while (low < high) {
8892         mid = (low + high) / 2;
8893         assert(mid <= highest_element);
8894         if (array[mid] <= cp) { /* cp >= array[mid] */
8895             low = mid + 1;
8896
8897             /* We could do this extra test to exit the loop early.
8898             if (cp < array[low]) {
8899                 return mid;
8900             }
8901             */
8902         }
8903         else { /* cp < array[mid] */
8904             high = mid;
8905         }
8906     }
8907
8908   found_entry:
8909     high--;
8910     invlist_set_previous_index(invlist, high);
8911     return high;
8912 }
8913
8914 void
8915 Perl__invlist_populate_swatch(SV* const invlist,
8916                               const UV start, const UV end, U8* swatch)
8917 {
8918     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8919      * but is used when the swash has an inversion list.  This makes this much
8920      * faster, as it uses a binary search instead of a linear one.  This is
8921      * intimately tied to that function, and perhaps should be in utf8.c,
8922      * except it is intimately tied to inversion lists as well.  It assumes
8923      * that <swatch> is all 0's on input */
8924
8925     UV current = start;
8926     const IV len = _invlist_len(invlist);
8927     IV i;
8928     const UV * array;
8929
8930     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8931
8932     if (len == 0) { /* Empty inversion list */
8933         return;
8934     }
8935
8936     array = invlist_array(invlist);
8937
8938     /* Find which element it is */
8939     i = _invlist_search(invlist, start);
8940
8941     /* We populate from <start> to <end> */
8942     while (current < end) {
8943         UV upper;
8944
8945         /* The inversion list gives the results for every possible code point
8946          * after the first one in the list.  Only those ranges whose index is
8947          * even are ones that the inversion list matches.  For the odd ones,
8948          * and if the initial code point is not in the list, we have to skip
8949          * forward to the next element */
8950         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8951             i++;
8952             if (i >= len) { /* Finished if beyond the end of the array */
8953                 return;
8954             }
8955             current = array[i];
8956             if (current >= end) {   /* Finished if beyond the end of what we
8957                                        are populating */
8958                 if (LIKELY(end < UV_MAX)) {
8959                     return;
8960                 }
8961
8962                 /* We get here when the upper bound is the maximum
8963                  * representable on the machine, and we are looking for just
8964                  * that code point.  Have to special case it */
8965                 i = len;
8966                 goto join_end_of_list;
8967             }
8968         }
8969         assert(current >= start);
8970
8971         /* The current range ends one below the next one, except don't go past
8972          * <end> */
8973         i++;
8974         upper = (i < len && array[i] < end) ? array[i] : end;
8975
8976         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8977          * for each code point in it */
8978         for (; current < upper; current++) {
8979             const STRLEN offset = (STRLEN)(current - start);
8980             swatch[offset >> 3] |= 1 << (offset & 7);
8981         }
8982
8983       join_end_of_list:
8984
8985         /* Quit if at the end of the list */
8986         if (i >= len) {
8987
8988             /* But first, have to deal with the highest possible code point on
8989              * the platform.  The previous code assumes that <end> is one
8990              * beyond where we want to populate, but that is impossible at the
8991              * platform's infinity, so have to handle it specially */
8992             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8993             {
8994                 const STRLEN offset = (STRLEN)(end - start);
8995                 swatch[offset >> 3] |= 1 << (offset & 7);
8996             }
8997             return;
8998         }
8999
9000         /* Advance to the next range, which will be for code points not in the
9001          * inversion list */
9002         current = array[i];
9003     }
9004
9005     return;
9006 }
9007
9008 void
9009 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9010                                          const bool complement_b, SV** output)
9011 {
9012     /* Take the union of two inversion lists and point '*output' to it.  On
9013      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9014      * even 'a' or 'b').  If to an inversion list, the contents of the original
9015      * list will be replaced by the union.  The first list, 'a', may be
9016      * NULL, in which case a copy of the second list is placed in '*output'.
9017      * If 'complement_b' is TRUE, the union is taken of the complement
9018      * (inversion) of 'b' instead of b itself.
9019      *
9020      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9021      * Richard Gillam, published by Addison-Wesley, and explained at some
9022      * length there.  The preface says to incorporate its examples into your
9023      * code at your own risk.
9024      *
9025      * The algorithm is like a merge sort. */
9026
9027     const UV* array_a;    /* a's array */
9028     const UV* array_b;
9029     UV len_a;       /* length of a's array */
9030     UV len_b;
9031
9032     SV* u;                      /* the resulting union */
9033     UV* array_u;
9034     UV len_u = 0;
9035
9036     UV i_a = 0;             /* current index into a's array */
9037     UV i_b = 0;
9038     UV i_u = 0;
9039
9040     /* running count, as explained in the algorithm source book; items are
9041      * stopped accumulating and are output when the count changes to/from 0.
9042      * The count is incremented when we start a range that's in an input's set,
9043      * and decremented when we start a range that's not in a set.  So this
9044      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9045      * and hence nothing goes into the union; 1, just one of the inputs is in
9046      * its set (and its current range gets added to the union); and 2 when both
9047      * inputs are in their sets.  */
9048     UV count = 0;
9049
9050     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9051     assert(a != b);
9052     assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
9053
9054     len_b = _invlist_len(b);
9055     if (len_b == 0) {
9056
9057         /* Here, 'b' is empty, hence it's complement is all possible code
9058          * points.  So if the union includes the complement of 'b', it includes
9059          * everything, and we need not even look at 'a'.  It's easiest to
9060          * create a new inversion list that matches everything.  */
9061         if (complement_b) {
9062             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9063
9064             if (*output == NULL) { /* If the output didn't exist, just point it
9065                                       at the new list */
9066                 *output = everything;
9067             }
9068             else { /* Otherwise, replace its contents with the new list */
9069                 invlist_replace_list_destroys_src(*output, everything);
9070                 SvREFCNT_dec_NN(everything);
9071             }
9072
9073             return;
9074         }
9075
9076         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9077          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9078          * output will be empty */
9079
9080         if (a == NULL || _invlist_len(a) == 0) {
9081             if (*output == NULL) {
9082                 *output = _new_invlist(0);
9083             }
9084             else {
9085                 invlist_clear(*output);
9086             }
9087             return;
9088         }
9089
9090         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9091          * union.  We can just return a copy of 'a' if '*output' doesn't point
9092          * to an existing list */
9093         if (*output == NULL) {
9094             *output = invlist_clone(a);
9095             return;
9096         }
9097
9098         /* If the output is to overwrite 'a', we have a no-op, as it's
9099          * already in 'a' */
9100         if (*output == a) {
9101             return;
9102         }
9103
9104         /* Here, '*output' is to be overwritten by 'a' */
9105         u = invlist_clone(a);
9106         invlist_replace_list_destroys_src(*output, u);
9107         SvREFCNT_dec_NN(u);
9108
9109         return;
9110     }
9111
9112     /* Here 'b' is not empty.  See about 'a' */
9113
9114     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9115
9116         /* Here, 'a' is empty (and b is not).  That means the union will come
9117          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9118          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9119          * the clone */
9120
9121         SV ** dest = (*output == NULL) ? output : &u;
9122         *dest = invlist_clone(b);
9123         if (complement_b) {
9124             _invlist_invert(*dest);
9125         }
9126
9127         if (dest == &u) {
9128             invlist_replace_list_destroys_src(*output, u);
9129             SvREFCNT_dec_NN(u);
9130         }
9131
9132         return;
9133     }
9134
9135     /* Here both lists exist and are non-empty */
9136     array_a = invlist_array(a);
9137     array_b = invlist_array(b);
9138
9139     /* If are to take the union of 'a' with the complement of b, set it
9140      * up so are looking at b's complement. */
9141     if (complement_b) {
9142
9143         /* To complement, we invert: if the first element is 0, remove it.  To
9144          * do this, we just pretend the array starts one later */
9145         if (array_b[0] == 0) {
9146             array_b++;
9147             len_b--;
9148         }
9149         else {
9150
9151             /* But if the first element is not zero, we pretend the list starts
9152              * at the 0 that is always stored immediately before the array. */
9153             array_b--;
9154             len_b++;
9155         }
9156     }
9157
9158     /* Size the union for the worst case: that the sets are completely
9159      * disjoint */
9160     u = _new_invlist(len_a + len_b);
9161
9162     /* Will contain U+0000 if either component does */
9163     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9164                                       || (len_b > 0 && array_b[0] == 0));
9165
9166     /* Go through each input list item by item, stopping when have exhausted
9167      * one of them */
9168     while (i_a < len_a && i_b < len_b) {
9169         UV cp;      /* The element to potentially add to the union's array */
9170         bool cp_in_set;   /* is it in the the input list's set or not */
9171
9172         /* We need to take one or the other of the two inputs for the union.
9173          * Since we are merging two sorted lists, we take the smaller of the
9174          * next items.  In case of a tie, we take first the one that is in its
9175          * set.  If we first took the one not in its set, it would decrement
9176          * the count, possibly to 0 which would cause it to be output as ending
9177          * the range, and the next time through we would take the same number,
9178          * and output it again as beginning the next range.  By doing it the
9179          * opposite way, there is no possibility that the count will be
9180          * momentarily decremented to 0, and thus the two adjoining ranges will
9181          * be seamlessly merged.  (In a tie and both are in the set or both not
9182          * in the set, it doesn't matter which we take first.) */
9183         if (       array_a[i_a] < array_b[i_b]
9184             || (   array_a[i_a] == array_b[i_b]
9185                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9186         {
9187             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9188             cp = array_a[i_a++];
9189         }
9190         else {
9191             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9192             cp = array_b[i_b++];
9193         }
9194
9195         /* Here, have chosen which of the two inputs to look at.  Only output
9196          * if the running count changes to/from 0, which marks the
9197          * beginning/end of a range that's in the set */
9198         if (cp_in_set) {
9199             if (count == 0) {
9200                 array_u[i_u++] = cp;
9201             }
9202             count++;
9203         }
9204         else {
9205             count--;
9206             if (count == 0) {
9207                 array_u[i_u++] = cp;
9208             }
9209         }
9210     }
9211
9212
9213     /* The loop above increments the index into exactly one of the input lists
9214      * each iteration, and ends when either index gets to its list end.  That
9215      * means the other index is lower than its end, and so something is
9216      * remaining in that one.  We decrement 'count', as explained below, if
9217      * that list is in its set.  (i_a and i_b each currently index the element
9218      * beyond the one we care about.) */
9219     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9220         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9221     {
9222         count--;
9223     }
9224
9225     /* Above we decremented 'count' if the list that had unexamined elements in
9226      * it was in its set.  This has made it so that 'count' being non-zero
9227      * means there isn't anything left to output; and 'count' equal to 0 means
9228      * that what is left to output is precisely that which is left in the
9229      * non-exhausted input list.
9230      *
9231      * To see why, note first that the exhausted input obviously has nothing
9232      * left to add to the union.  If it was in its set at its end, that means
9233      * the set extends from here to the platform's infinity, and hence so does
9234      * the union and the non-exhausted set is irrelevant.  The exhausted set
9235      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9236      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9237      * 'count' remains at 1.  This is consistent with the decremented 'count'
9238      * != 0 meaning there's nothing left to add to the union.
9239      *
9240      * But if the exhausted input wasn't in its set, it contributed 0 to
9241      * 'count', and the rest of the union will be whatever the other input is.
9242      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9243      * otherwise it gets decremented to 0.  This is consistent with 'count'
9244      * == 0 meaning the remainder of the union is whatever is left in the
9245      * non-exhausted list. */
9246     if (count != 0) {
9247         len_u = i_u;
9248     }
9249     else {
9250         IV copy_count = len_a - i_a;
9251         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9252             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9253         }
9254         else { /* The non-exhausted input is b */
9255             copy_count = len_b - i_b;
9256             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9257         }
9258         len_u = i_u + copy_count;
9259     }
9260
9261     /* Set the result to the final length, which can change the pointer to
9262      * array_u, so re-find it.  (Note that it is unlikely that this will
9263      * change, as we are shrinking the space, not enlarging it) */
9264     if (len_u != _invlist_len(u)) {
9265         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9266         invlist_trim(u);
9267         array_u = invlist_array(u);
9268     }
9269
9270     if (*output == NULL) {  /* Simply return the new inversion list */
9271         *output = u;
9272     }
9273     else {
9274         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9275          * could instead free '*output', and then set it to 'u', but experience
9276          * has shown [perl #127392] that if the input is a mortal, we can get a
9277          * huge build-up of these during regex compilation before they get
9278          * freed. */
9279         invlist_replace_list_destroys_src(*output, u);
9280         SvREFCNT_dec_NN(u);
9281     }
9282
9283     return;
9284 }
9285
9286 void
9287 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9288                                                const bool complement_b, SV** i)
9289 {
9290     /* Take the intersection of two inversion lists and point '*i' to it.  On
9291      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9292      * even 'a' or 'b').  If to an inversion list, the contents of the original
9293      * list will be replaced by the intersection.  The first list, 'a', may be
9294      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9295      * TRUE, the result will be the intersection of 'a' and the complement (or
9296      * inversion) of 'b' instead of 'b' directly.
9297      *
9298      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9299      * Richard Gillam, published by Addison-Wesley, and explained at some
9300      * length there.  The preface says to incorporate its examples into your
9301      * code at your own risk.  In fact, it had bugs
9302      *
9303      * The algorithm is like a merge sort, and is essentially the same as the
9304      * union above
9305      */
9306
9307     const UV* array_a;          /* a's array */
9308     const UV* array_b;
9309     UV len_a;   /* length of a's array */
9310     UV len_b;
9311
9312     SV* r;                   /* the resulting intersection */
9313     UV* array_r;
9314     UV len_r = 0;
9315
9316     UV i_a = 0;             /* current index into a's array */
9317     UV i_b = 0;
9318     UV i_r = 0;
9319
9320     /* running count of how many of the two inputs are postitioned at ranges
9321      * that are in their sets.  As explained in the algorithm source book,
9322      * items are stopped accumulating and are output when the count changes
9323      * to/from 2.  The count is incremented when we start a range that's in an
9324      * input's set, and decremented when we start a range that's not in a set.
9325      * Only when it is 2 are we in the intersection. */
9326     UV count = 0;
9327
9328     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9329     assert(a != b);
9330     assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
9331
9332     /* Special case if either one is empty */
9333     len_a = (a == NULL) ? 0 : _invlist_len(a);
9334     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9335         if (len_a != 0 && complement_b) {
9336
9337             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9338              * must be empty.  Here, also we are using 'b's complement, which
9339              * hence must be every possible code point.  Thus the intersection
9340              * is simply 'a'. */
9341
9342             if (*i == a) {  /* No-op */
9343                 return;
9344             }
9345
9346             if (*i == NULL) {
9347                 *i = invlist_clone(a);
9348                 return;
9349             }
9350
9351             r = invlist_clone(a);
9352             invlist_replace_list_destroys_src(*i, r);
9353             SvREFCNT_dec_NN(r);
9354             return;
9355         }
9356
9357         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9358          * intersection must be empty */
9359         if (*i == NULL) {
9360             *i = _new_invlist(0);
9361             return;
9362         }
9363
9364         invlist_clear(*i);
9365         return;
9366     }
9367
9368     /* Here both lists exist and are non-empty */
9369     array_a = invlist_array(a);
9370     array_b = invlist_array(b);
9371
9372     /* If are to take the intersection of 'a' with the complement of b, set it
9373      * up so are looking at b's complement. */
9374     if (complement_b) {
9375
9376         /* To complement, we invert: if the first element is 0, remove it.  To
9377          * do this, we just pretend the array starts one later */
9378         if (array_b[0] == 0) {
9379             array_b++;
9380             len_b--;
9381         }
9382         else {
9383
9384             /* But if the first element is not zero, we pretend the list starts
9385              * at the 0 that is always stored immediately before the array. */
9386             array_b--;
9387             len_b++;
9388         }
9389     }
9390
9391     /* Size the intersection for the worst case: that the intersection ends up
9392      * fragmenting everything to be completely disjoint */
9393     r= _new_invlist(len_a + len_b);
9394
9395     /* Will contain U+0000 iff both components do */
9396     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9397                                      && len_b > 0 && array_b[0] == 0);
9398
9399     /* Go through each list item by item, stopping when have exhausted one of
9400      * them */
9401     while (i_a < len_a && i_b < len_b) {
9402         UV cp;      /* The element to potentially add to the intersection's
9403                        array */
9404         bool cp_in_set; /* Is it in the input list's set or not */
9405
9406         /* We need to take one or the other of the two inputs for the
9407          * intersection.  Since we are merging two sorted lists, we take the
9408          * smaller of the next items.  In case of a tie, we take first the one
9409          * that is not in its set (a difference from the union algorithm).  If
9410          * we first took the one in its set, it would increment the count,
9411          * possibly to 2 which would cause it to be output as starting a range
9412          * in the intersection, and the next time through we would take that
9413          * same number, and output it again as ending the set.  By doing the
9414          * opposite of this, there is no possibility that the count will be
9415          * momentarily incremented to 2.  (In a tie and both are in the set or
9416          * both not in the set, it doesn't matter which we take first.) */
9417         if (       array_a[i_a] < array_b[i_b]
9418             || (   array_a[i_a] == array_b[i_b]
9419                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9420         {
9421             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9422             cp = array_a[i_a++];
9423         }
9424         else {
9425             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9426             cp= array_b[i_b++];
9427         }
9428
9429         /* Here, have chosen which of the two inputs to look at.  Only output
9430          * if the running count changes to/from 2, which marks the
9431          * beginning/end of a range that's in the intersection */
9432         if (cp_in_set) {
9433             count++;
9434             if (count == 2) {
9435                 array_r[i_r++] = cp;
9436             }
9437         }
9438         else {
9439             if (count == 2) {
9440                 array_r[i_r++] = cp;
9441             }
9442             count--;
9443         }
9444
9445     }
9446
9447     /* The loop above increments the index into exactly one of the input lists
9448      * each iteration, and ends when either index gets to its list end.  That
9449      * means the other index is lower than its end, and so something is
9450      * remaining in that one.  We increment 'count', as explained below, if the
9451      * exhausted list was in its set.  (i_a and i_b each currently index the
9452      * element beyond the one we care about.) */
9453     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9454         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9455     {
9456         count++;
9457     }
9458
9459     /* Above we incremented 'count' if the exhausted list was in its set.  This
9460      * has made it so that 'count' being below 2 means there is nothing left to
9461      * output; otheriwse what's left to add to the intersection is precisely
9462      * that which is left in the non-exhausted input list.
9463      *
9464      * To see why, note first that the exhausted input obviously has nothing
9465      * left to affect the intersection.  If it was in its set at its end, that
9466      * means the set extends from here to the platform's infinity, and hence
9467      * anything in the non-exhausted's list will be in the intersection, and
9468      * anything not in it won't be.  Hence, the rest of the intersection is
9469      * precisely what's in the non-exhausted list  The exhausted set also
9470      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9471      * it means 'count' is now at least 2.  This is consistent with the
9472      * incremented 'count' being >= 2 means to add the non-exhausted list to
9473      * the intersection.
9474      *
9475      * But if the exhausted input wasn't in its set, it contributed 0 to
9476      * 'count', and the intersection can't include anything further; the
9477      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9478      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9479      * further to add to the intersection. */
9480     if (count < 2) { /* Nothing left to put in the intersection. */
9481         len_r = i_r;
9482     }
9483     else { /* copy the non-exhausted list, unchanged. */
9484         IV copy_count = len_a - i_a;
9485         if (copy_count > 0) {   /* a is the one with stuff left */
9486             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9487         }
9488         else {  /* b is the one with stuff left */
9489             copy_count = len_b - i_b;
9490             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9491         }
9492         len_r = i_r + copy_count;
9493     }
9494
9495     /* Set the result to the final length, which can change the pointer to
9496      * array_r, so re-find it.  (Note that it is unlikely that this will
9497      * change, as we are shrinking the space, not enlarging it) */
9498     if (len_r != _invlist_len(r)) {
9499         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9500         invlist_trim(r);
9501         array_r = invlist_array(r);
9502     }
9503
9504     if (*i == NULL) { /* Simply return the calculated intersection */
9505         *i = r;
9506     }
9507     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9508               instead free '*i', and then set it to 'r', but experience has
9509               shown [perl #127392] that if the input is a mortal, we can get a
9510               huge build-up of these during regex compilation before they get
9511               freed. */
9512         if (len_r) {
9513             invlist_replace_list_destroys_src(*i, r);
9514         }
9515         else {
9516             invlist_clear(*i);
9517         }
9518         SvREFCNT_dec_NN(r);
9519     }
9520
9521     return;
9522 }
9523
9524 SV*
9525 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9526 {
9527     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9528      * set.  A pointer to the inversion list is returned.  This may actually be
9529      * a new list, in which case the passed in one has been destroyed.  The
9530      * passed-in inversion list can be NULL, in which case a new one is created
9531      * with just the one range in it.  The new list is not necessarily
9532      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9533      * result of this function.  The gain would not be large, and in many
9534      * cases, this is called multiple times on a single inversion list, so
9535      * anything freed may almost immediately be needed again.
9536      *
9537      * This used to mostly call the 'union' routine, but that is much more
9538      * heavyweight than really needed for a single range addition */
9539
9540     UV* array;              /* The array implementing the inversion list */
9541     UV len;                 /* How many elements in 'array' */
9542     SSize_t i_s;            /* index into the invlist array where 'start'
9543                                should go */
9544     SSize_t i_e = 0;        /* And the index where 'end' should go */
9545     UV cur_highest;         /* The highest code point in the inversion list
9546                                upon entry to this function */
9547
9548     /* This range becomes the whole inversion list if none already existed */
9549     if (invlist == NULL) {
9550         invlist = _new_invlist(2);
9551         _append_range_to_invlist(invlist, start, end);
9552         return invlist;
9553     }
9554
9555     /* Likewise, if the inversion list is currently empty */
9556     len = _invlist_len(invlist);
9557     if (len == 0) {
9558         _append_range_to_invlist(invlist, start, end);
9559         return invlist;
9560     }
9561
9562     /* Starting here, we have to know the internals of the list */
9563     array = invlist_array(invlist);
9564
9565     /* If the new range ends higher than the current highest ... */
9566     cur_highest = invlist_highest(invlist);
9567     if (end > cur_highest) {
9568
9569         /* If the whole range is higher, we can just append it */
9570         if (start > cur_highest) {
9571             _append_range_to_invlist(invlist, start, end);
9572             return invlist;
9573         }
9574
9575         /* Otherwise, add the portion that is higher ... */
9576         _append_range_to_invlist(invlist, cur_highest + 1, end);
9577
9578         /* ... and continue on below to handle the rest.  As a result of the
9579          * above append, we know that the index of the end of the range is the
9580          * final even numbered one of the array.  Recall that the final element
9581          * always starts a range that extends to infinity.  If that range is in
9582          * the set (meaning the set goes from here to infinity), it will be an
9583          * even index, but if it isn't in the set, it's odd, and the final
9584          * range in the set is one less, which is even. */
9585         if (end == UV_MAX) {
9586             i_e = len;
9587         }
9588         else {
9589             i_e = len - 2;
9590         }
9591     }
9592
9593     /* We have dealt with appending, now see about prepending.  If the new
9594      * range starts lower than the current lowest ... */
9595     if (start < array[0]) {
9596
9597         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
9598          * Let the union code handle it, rather than having to know the
9599          * trickiness in two code places.  */
9600         if (UNLIKELY(start == 0)) {
9601             SV* range_invlist;
9602
9603             range_invlist = _new_invlist(2);
9604             _append_range_to_invlist(range_invlist, start, end);
9605
9606             _invlist_union(invlist, range_invlist, &invlist);
9607
9608             SvREFCNT_dec_NN(range_invlist);
9609
9610             return invlist;
9611         }
9612
9613         /* If the whole new range comes before the first entry, and doesn't
9614          * extend it, we have to insert it as an additional range */
9615         if (end < array[0] - 1) {
9616             i_s = i_e = -1;
9617             goto splice_in_new_range;
9618         }
9619
9620         /* Here the new range adjoins the existing first range, extending it
9621          * downwards. */
9622         array[0] = start;
9623
9624         /* And continue on below to handle the rest.  We know that the index of
9625          * the beginning of the range is the first one of the array */
9626         i_s = 0;
9627     }
9628     else { /* Not prepending any part of the new range to the existing list.
9629             * Find where in the list it should go.  This finds i_s, such that:
9630             *     invlist[i_s] <= start < array[i_s+1]
9631             */
9632         i_s = _invlist_search(invlist, start);
9633     }
9634
9635     /* At this point, any extending before the beginning of the inversion list
9636      * and/or after the end has been done.  This has made it so that, in the
9637      * code below, each endpoint of the new range is either in a range that is
9638      * in the set, or is in a gap between two ranges that are.  This means we
9639      * don't have to worry about exceeding the array bounds.
9640      *
9641      * Find where in the list the new range ends (but we can skip this if we
9642      * have already determined what it is, or if it will be the same as i_s,
9643      * which we already have computed) */
9644     if (i_e == 0) {
9645         i_e = (start == end)
9646               ? i_s
9647               : _invlist_search(invlist, end);
9648     }
9649
9650     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
9651      * is a range that goes to infinity there is no element at invlist[i_e+1],
9652      * so only the first relation holds. */
9653
9654     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9655
9656         /* Here, the ranges on either side of the beginning of the new range
9657          * are in the set, and this range starts in the gap between them.
9658          *
9659          * The new range extends the range above it downwards if the new range
9660          * ends at or above that range's start */
9661         const bool extends_the_range_above = (   end == UV_MAX
9662                                               || end + 1 >= array[i_s+1]);
9663
9664         /* The new range extends the range below it upwards if it begins just
9665          * after where that range ends */
9666         if (start == array[i_s]) {
9667
9668             /* If the new range fills the entire gap between the other ranges,
9669              * they will get merged together.  Other ranges may also get
9670              * merged, depending on how many of them the new range spans.  In
9671              * the general case, we do the merge later, just once, after we
9672              * figure out how many to merge.  But in the case where the new
9673              * range exactly spans just this one gap (possibly extending into
9674              * the one above), we do the merge here, and an early exit.  This
9675              * is done here to avoid having to special case later. */
9676             if (i_e - i_s <= 1) {
9677
9678                 /* If i_e - i_s == 1, it means that the new range terminates
9679                  * within the range above, and hence 'extends_the_range_above'
9680                  * must be true.  (If the range above it extends to infinity,
9681                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
9682                  * will be 0, so no harm done.) */
9683                 if (extends_the_range_above) {
9684                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
9685                     invlist_set_len(invlist,
9686                                     len - 2,
9687                                     *(get_invlist_offset_addr(invlist)));
9688                     return invlist;
9689                 }
9690
9691                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
9692                  * to the same range, and below we are about to decrement i_s
9693                  * */
9694                 i_e--;
9695             }
9696
9697             /* Here, the new range is adjacent to the one below.  (It may also
9698              * span beyond the range above, but that will get resolved later.)
9699              * Extend the range below to include this one. */
9700             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
9701             i_s--;
9702             start = array[i_s];
9703         }
9704         else if (extends_the_range_above) {
9705
9706             /* Here the new range only extends the range above it, but not the
9707              * one below.  It merges with the one above.  Again, we keep i_e
9708              * and i_s in sync if they point to the same range */
9709             if (i_e == i_s) {
9710                 i_e++;
9711             }
9712             i_s++;
9713             array[i_s] = start;
9714         }
9715     }
9716
9717     /* Here, we've dealt with the new range start extending any adjoining
9718      * existing ranges.
9719      *
9720      * If the new range extends to infinity, it is now the final one,
9721      * regardless of what was there before */
9722     if (UNLIKELY(end == UV_MAX)) {
9723         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
9724         return invlist;
9725     }
9726
9727     /* If i_e started as == i_s, it has also been dealt with,
9728      * and been updated to the new i_s, which will fail the following if */
9729     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
9730
9731         /* Here, the ranges on either side of the end of the new range are in
9732          * the set, and this range ends in the gap between them.
9733          *
9734          * If this range is adjacent to (hence extends) the range above it, it
9735          * becomes part of that range; likewise if it extends the range below,
9736          * it becomes part of that range */
9737         if (end + 1 == array[i_e+1]) {
9738             i_e++;
9739             array[i_e] = start;
9740         }
9741         else if (start <= array[i_e]) {
9742             array[i_e] = end + 1;
9743             i_e--;
9744         }
9745     }
9746
9747     if (i_s == i_e) {
9748
9749         /* If the range fits entirely in an existing range (as possibly already
9750          * extended above), it doesn't add anything new */
9751         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9752             return invlist;
9753         }
9754
9755         /* Here, no part of the range is in the list.  Must add it.  It will
9756          * occupy 2 more slots */
9757       splice_in_new_range:
9758
9759         invlist_extend(invlist, len + 2);
9760         array = invlist_array(invlist);
9761         /* Move the rest of the array down two slots. Don't include any
9762          * trailing NUL */
9763         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
9764
9765         /* Do the actual splice */
9766         array[i_e+1] = start;
9767         array[i_e+2] = end + 1;
9768         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
9769         return invlist;
9770     }
9771
9772     /* Here the new range crossed the boundaries of a pre-existing range.  The
9773      * code above has adjusted things so that both ends are in ranges that are
9774      * in the set.  This means everything in between must also be in the set.
9775      * Just squash things together */
9776     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
9777     invlist_set_len(invlist,
9778                     len - i_e + i_s,
9779                     *(get_invlist_offset_addr(invlist)));
9780
9781     return invlist;
9782 }
9783
9784 SV*
9785 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9786                                  UV** other_elements_ptr)
9787 {
9788     /* Create and return an inversion list whose contents are to be populated
9789      * by the caller.  The caller gives the number of elements (in 'size') and
9790      * the very first element ('element0').  This function will set
9791      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9792      * are to be placed.
9793      *
9794      * Obviously there is some trust involved that the caller will properly
9795      * fill in the other elements of the array.
9796      *
9797      * (The first element needs to be passed in, as the underlying code does
9798      * things differently depending on whether it is zero or non-zero) */
9799
9800     SV* invlist = _new_invlist(size);
9801     bool offset;
9802
9803     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9804
9805     invlist = add_cp_to_invlist(invlist, element0);
9806     offset = *get_invlist_offset_addr(invlist);
9807
9808     invlist_set_len(invlist, size, offset);
9809     *other_elements_ptr = invlist_array(invlist) + 1;
9810     return invlist;
9811 }
9812
9813 #endif
9814
9815 PERL_STATIC_INLINE SV*
9816 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9817     return _add_range_to_invlist(invlist, cp, cp);
9818 }
9819
9820 #ifndef PERL_IN_XSUB_RE
9821 void
9822 Perl__invlist_invert(pTHX_ SV* const invlist)
9823 {
9824     /* Complement the input inversion list.  This adds a 0 if the list didn't
9825      * have a zero; removes it otherwise.  As described above, the data
9826      * structure is set up so that this is very efficient */
9827
9828     PERL_ARGS_ASSERT__INVLIST_INVERT;
9829
9830     assert(! invlist_is_iterating(invlist));
9831
9832     /* The inverse of matching nothing is matching everything */
9833     if (_invlist_len(invlist) == 0) {
9834         _append_range_to_invlist(invlist, 0, UV_MAX);
9835         return;
9836     }
9837
9838     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9839 }
9840
9841 #endif
9842
9843 PERL_STATIC_INLINE SV*
9844 S_invlist_clone(pTHX_ SV* const invlist)
9845 {
9846
9847     /* Return a new inversion list that is a copy of the input one, which is
9848      * unchanged.  The new list will not be mortal even if the old one was. */
9849
9850     /* Need to allocate extra space to accommodate Perl's addition of a
9851      * trailing NUL to SvPV's, since it thinks they are always strings */
9852     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9853     STRLEN physical_length = SvCUR(invlist);
9854     bool offset = *(get_invlist_offset_addr(invlist));
9855
9856     PERL_ARGS_ASSERT_INVLIST_CLONE;
9857
9858     *(get_invlist_offset_addr(new_invlist)) = offset;
9859     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9860     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9861
9862     return new_invlist;
9863 }
9864
9865 PERL_STATIC_INLINE STRLEN*
9866 S_get_invlist_iter_addr(SV* invlist)
9867 {
9868     /* Return the address of the UV that contains the current iteration
9869      * position */
9870
9871     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9872
9873     assert(SvTYPE(invlist) == SVt_INVLIST);
9874
9875     return &(((XINVLIST*) SvANY(invlist))->iterator);
9876 }
9877
9878 PERL_STATIC_INLINE void
9879 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9880 {
9881     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9882
9883     *get_invlist_iter_addr(invlist) = 0;
9884 }
9885
9886 PERL_STATIC_INLINE void
9887 S_invlist_iterfinish(SV* invlist)
9888 {
9889     /* Terminate iterator for invlist.  This is to catch development errors.
9890      * Any iteration that is interrupted before completed should call this
9891      * function.  Functions that add code points anywhere else but to the end
9892      * of an inversion list assert that they are not in the middle of an
9893      * iteration.  If they were, the addition would make the iteration
9894      * problematical: if the iteration hadn't reached the place where things
9895      * were being added, it would be ok */
9896
9897     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9898
9899     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9900 }
9901
9902 STATIC bool
9903 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9904 {
9905     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9906      * This call sets in <*start> and <*end>, the next range in <invlist>.
9907      * Returns <TRUE> if successful and the next call will return the next
9908      * range; <FALSE> if was already at the end of the list.  If the latter,
9909      * <*start> and <*end> are unchanged, and the next call to this function
9910      * will start over at the beginning of the list */
9911
9912     STRLEN* pos = get_invlist_iter_addr(invlist);
9913     UV len = _invlist_len(invlist);
9914     UV *array;
9915
9916     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9917
9918     if (*pos >= len) {
9919         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9920         return FALSE;
9921     }
9922
9923     array = invlist_array(invlist);
9924
9925     *start = array[(*pos)++];
9926
9927     if (*pos >= len) {
9928         *end = UV_MAX;
9929     }
9930     else {
9931         *end = array[(*pos)++] - 1;
9932     }
9933
9934     return TRUE;
9935 }
9936
9937 PERL_STATIC_INLINE UV
9938 S_invlist_highest(SV* const invlist)
9939 {
9940     /* Returns the highest code point that matches an inversion list.  This API
9941      * has an ambiguity, as it returns 0 under either the highest is actually
9942      * 0, or if the list is empty.  If this distinction matters to you, check
9943      * for emptiness before calling this function */
9944
9945     UV len = _invlist_len(invlist);
9946     UV *array;
9947
9948     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9949
9950     if (len == 0) {
9951         return 0;
9952     }
9953
9954     array = invlist_array(invlist);
9955
9956     /* The last element in the array in the inversion list always starts a
9957      * range that goes to infinity.  That range may be for code points that are
9958      * matched in the inversion list, or it may be for ones that aren't
9959      * matched.  In the latter case, the highest code point in the set is one
9960      * less than the beginning of this range; otherwise it is the final element
9961      * of this range: infinity */
9962     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9963            ? UV_MAX
9964            : array[len - 1] - 1;
9965 }
9966
9967 STATIC SV *
9968 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
9969 {
9970     /* Get the contents of an inversion list into a string SV so that they can
9971      * be printed out.  If 'traditional_style' is TRUE, it uses the format
9972      * traditionally done for debug tracing; otherwise it uses a format
9973      * suitable for just copying to the output, with blanks between ranges and
9974      * a dash between range components */
9975
9976     UV start, end;
9977     SV* output;
9978     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
9979     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
9980
9981     if (traditional_style) {
9982         output = newSVpvs("\n");
9983     }
9984     else {
9985         output = newSVpvs("");
9986     }
9987
9988     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
9989
9990     assert(! invlist_is_iterating(invlist));
9991
9992     invlist_iterinit(invlist);
9993     while (invlist_iternext(invlist, &start, &end)) {
9994         if (end == UV_MAX) {
9995             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFINITY%c",
9996                                           start, intra_range_delimiter,
9997                                                  inter_range_delimiter);
9998         }
9999         else if (end != start) {
10000             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10001                                           start,
10002                                                    intra_range_delimiter,
10003                                                   end, inter_range_delimiter);
10004         }
10005         else {
10006             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10007                                           start, inter_range_delimiter);
10008         }
10009     }
10010
10011     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10012         SvCUR_set(output, SvCUR(output) - 1);
10013     }
10014
10015     return output;
10016 }
10017
10018 #ifndef PERL_IN_XSUB_RE
10019 void
10020 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10021                          const char * const indent, SV* const invlist)
10022 {
10023     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10024      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10025      * the string 'indent'.  The output looks like this:
10026          [0] 0x000A .. 0x000D
10027          [2] 0x0085
10028          [4] 0x2028 .. 0x2029
10029          [6] 0x3104 .. INFINITY
10030      * This means that the first range of code points matched by the list are
10031      * 0xA through 0xD; the second range contains only the single code point
10032      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10033      * are used to define each range (except if the final range extends to
10034      * infinity, only a single element is needed).  The array index of the
10035      * first element for the corresponding range is given in brackets. */
10036
10037     UV start, end;
10038     STRLEN count = 0;
10039
10040     PERL_ARGS_ASSERT__INVLIST_DUMP;
10041
10042     if (invlist_is_iterating(invlist)) {
10043         Perl_dump_indent(aTHX_ level, file,
10044              "%sCan't dump inversion list because is in middle of iterating\n",
10045              indent);
10046         return;
10047     }
10048
10049     invlist_iterinit(invlist);
10050     while (invlist_iternext(invlist, &start, &end)) {
10051         if (end == UV_MAX) {
10052             Perl_dump_indent(aTHX_ level, file,
10053                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFINITY\n",
10054                                    indent, (UV)count, start);
10055         }
10056         else if (end != start) {
10057             Perl_dump_indent(aTHX_ level, file,
10058                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10059                                 indent, (UV)count, start,         end);
10060         }
10061         else {
10062             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10063                                             indent, (UV)count, start);
10064         }
10065         count += 2;
10066     }
10067 }
10068
10069 void
10070 Perl__load_PL_utf8_foldclosures (pTHX)
10071 {
10072     assert(! PL_utf8_foldclosures);
10073
10074     /* If the folds haven't been read in, call a fold function
10075      * to force that */
10076     if (! PL_utf8_tofold) {
10077         U8 dummy[UTF8_MAXBYTES_CASE+1];
10078         const U8 hyphen[] = HYPHEN_UTF8;
10079
10080         /* This string is just a short named one above \xff */
10081         toFOLD_utf8_safe(hyphen, hyphen + sizeof(hyphen) - 1, dummy, NULL);
10082         assert(PL_utf8_tofold); /* Verify that worked */
10083     }
10084     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10085 }
10086 #endif
10087
10088 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10089 bool
10090 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10091 {
10092     /* Return a boolean as to if the two passed in inversion lists are
10093      * identical.  The final argument, if TRUE, says to take the complement of
10094      * the second inversion list before doing the comparison */
10095
10096     const UV* array_a = invlist_array(a);
10097     const UV* array_b = invlist_array(b);
10098     UV len_a = _invlist_len(a);
10099     UV len_b = _invlist_len(b);
10100
10101     PERL_ARGS_ASSERT__INVLISTEQ;
10102
10103     /* If are to compare 'a' with the complement of b, set it
10104      * up so are looking at b's complement. */
10105     if (complement_b) {
10106
10107         /* The complement of nothing is everything, so <a> would have to have
10108          * just one element, starting at zero (ending at infinity) */
10109         if (len_b == 0) {
10110             return (len_a == 1 && array_a[0] == 0);
10111         }
10112         else if (array_b[0] == 0) {
10113
10114             /* Otherwise, to complement, we invert.  Here, the first element is
10115              * 0, just remove it.  To do this, we just pretend the array starts
10116              * one later */
10117
10118             array_b++;
10119             len_b--;
10120         }
10121         else {
10122
10123             /* But if the first element is not zero, we pretend the list starts
10124              * at the 0 that is always stored immediately before the array. */
10125             array_b--;
10126             len_b++;
10127         }
10128     }
10129
10130     return    len_a == len_b
10131            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10132
10133 }
10134 #endif
10135
10136 /*
10137  * As best we can, determine the characters that can match the start of
10138  * the given EXACTF-ish node.
10139  *
10140  * Returns the invlist as a new SV*; it is the caller's responsibility to
10141  * call SvREFCNT_dec() when done with it.
10142  */
10143 STATIC SV*
10144 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10145 {
10146     const U8 * s = (U8*)STRING(node);
10147     SSize_t bytelen = STR_LEN(node);
10148     UV uc;
10149     /* Start out big enough for 2 separate code points */
10150     SV* invlist = _new_invlist(4);
10151
10152     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10153
10154     if (! UTF) {
10155         uc = *s;
10156
10157         /* We punt and assume can match anything if the node begins
10158          * with a multi-character fold.  Things are complicated.  For
10159          * example, /ffi/i could match any of:
10160          *  "\N{LATIN SMALL LIGATURE FFI}"
10161          *  "\N{LATIN SMALL LIGATURE FF}I"
10162          *  "F\N{LATIN SMALL LIGATURE FI}"
10163          *  plus several other things; and making sure we have all the
10164          *  possibilities is hard. */
10165         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10166             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10167         }
10168         else {
10169             /* Any Latin1 range character can potentially match any
10170              * other depending on the locale */
10171             if (OP(node) == EXACTFL) {
10172                 _invlist_union(invlist, PL_Latin1, &invlist);
10173             }
10174             else {
10175                 /* But otherwise, it matches at least itself.  We can
10176                  * quickly tell if it has a distinct fold, and if so,
10177                  * it matches that as well */
10178                 invlist = add_cp_to_invlist(invlist, uc);
10179                 if (IS_IN_SOME_FOLD_L1(uc))
10180                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10181             }
10182
10183             /* Some characters match above-Latin1 ones under /i.  This
10184              * is true of EXACTFL ones when the locale is UTF-8 */
10185             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10186                 && (! isASCII(uc) || (OP(node) != EXACTFA
10187                                     && OP(node) != EXACTFA_NO_TRIE)))
10188             {
10189                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10190             }
10191         }
10192     }
10193     else {  /* Pattern is UTF-8 */
10194         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10195         STRLEN foldlen = UTF8SKIP(s);
10196         const U8* e = s + bytelen;
10197         SV** listp;
10198
10199         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10200
10201         /* The only code points that aren't folded in a UTF EXACTFish
10202          * node are are the problematic ones in EXACTFL nodes */
10203         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10204             /* We need to check for the possibility that this EXACTFL
10205              * node begins with a multi-char fold.  Therefore we fold
10206              * the first few characters of it so that we can make that
10207              * check */
10208             U8 *d = folded;
10209             int i;
10210
10211             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10212                 if (isASCII(*s)) {
10213                     *(d++) = (U8) toFOLD(*s);
10214                     s++;
10215                 }
10216                 else {
10217                     STRLEN len;
10218                     toFOLD_utf8_safe(s, e, d, &len);
10219                     d += len;
10220                     s += UTF8SKIP(s);
10221                 }
10222             }
10223
10224             /* And set up so the code below that looks in this folded
10225              * buffer instead of the node's string */
10226             e = d;
10227             foldlen = UTF8SKIP(folded);
10228             s = folded;
10229         }
10230
10231         /* When we reach here 's' points to the fold of the first
10232          * character(s) of the node; and 'e' points to far enough along
10233          * the folded string to be just past any possible multi-char
10234          * fold. 'foldlen' is the length in bytes of the first
10235          * character in 's'
10236          *
10237          * Unlike the non-UTF-8 case, the macro for determining if a
10238          * string is a multi-char fold requires all the characters to
10239          * already be folded.  This is because of all the complications
10240          * if not.  Note that they are folded anyway, except in EXACTFL
10241          * nodes.  Like the non-UTF case above, we punt if the node
10242          * begins with a multi-char fold  */
10243
10244         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10245             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10246         }
10247         else {  /* Single char fold */
10248
10249             /* It matches all the things that fold to it, which are
10250              * found in PL_utf8_foldclosures (including itself) */
10251             invlist = add_cp_to_invlist(invlist, uc);
10252             if (! PL_utf8_foldclosures)
10253                 _load_PL_utf8_foldclosures();
10254             if ((listp = hv_fetch(PL_utf8_foldclosures,
10255                                 (char *) s, foldlen, FALSE)))
10256             {
10257                 AV* list = (AV*) *listp;
10258                 IV k;
10259                 for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
10260                     SV** c_p = av_fetch(list, k, FALSE);
10261                     UV c;
10262                     assert(c_p);
10263
10264                     c = SvUV(*c_p);
10265
10266                     /* /aa doesn't allow folds between ASCII and non- */
10267                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
10268                         && isASCII(c) != isASCII(uc))
10269                     {
10270                         continue;
10271                     }
10272
10273                     invlist = add_cp_to_invlist(invlist, c);
10274                 }
10275             }
10276         }
10277     }
10278
10279     return invlist;
10280 }
10281
10282 #undef HEADER_LENGTH
10283 #undef TO_INTERNAL_SIZE
10284 #undef FROM_INTERNAL_SIZE
10285 #undef INVLIST_VERSION_ID
10286
10287 /* End of inversion list object */
10288
10289 STATIC void
10290 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10291 {
10292     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10293      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10294      * should point to the first flag; it is updated on output to point to the
10295      * final ')' or ':'.  There needs to be at least one flag, or this will
10296      * abort */
10297
10298     /* for (?g), (?gc), and (?o) warnings; warning
10299        about (?c) will warn about (?g) -- japhy    */
10300
10301 #define WASTED_O  0x01
10302 #define WASTED_G  0x02
10303 #define WASTED_C  0x04
10304 #define WASTED_GC (WASTED_G|WASTED_C)
10305     I32 wastedflags = 0x00;
10306     U32 posflags = 0, negflags = 0;
10307     U32 *flagsp = &posflags;
10308     char has_charset_modifier = '\0';
10309     regex_charset cs;
10310     bool has_use_defaults = FALSE;
10311     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10312     int x_mod_count = 0;
10313
10314     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10315
10316     /* '^' as an initial flag sets certain defaults */
10317     if (UCHARAT(RExC_parse) == '^') {
10318         RExC_parse++;
10319         has_use_defaults = TRUE;
10320         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10321         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10322                                         ? REGEX_UNICODE_CHARSET
10323                                         : REGEX_DEPENDS_CHARSET);
10324     }
10325
10326     cs = get_regex_charset(RExC_flags);
10327     if (cs == REGEX_DEPENDS_CHARSET
10328         && (RExC_utf8 || RExC_uni_semantics))
10329     {
10330         cs = REGEX_UNICODE_CHARSET;
10331     }
10332
10333     while (RExC_parse < RExC_end) {
10334         /* && strchr("iogcmsx", *RExC_parse) */
10335         /* (?g), (?gc) and (?o) are useless here
10336            and must be globally applied -- japhy */
10337         switch (*RExC_parse) {
10338
10339             /* Code for the imsxn flags */
10340             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10341
10342             case LOCALE_PAT_MOD:
10343                 if (has_charset_modifier) {
10344                     goto excess_modifier;
10345                 }
10346                 else if (flagsp == &negflags) {
10347                     goto neg_modifier;
10348                 }
10349                 cs = REGEX_LOCALE_CHARSET;
10350                 has_charset_modifier = LOCALE_PAT_MOD;
10351                 break;
10352             case UNICODE_PAT_MOD:
10353                 if (has_charset_modifier) {
10354                     goto excess_modifier;
10355                 }
10356                 else if (flagsp == &negflags) {
10357                     goto neg_modifier;
10358                 }
10359                 cs = REGEX_UNICODE_CHARSET;
10360                 has_charset_modifier = UNICODE_PAT_MOD;
10361                 break;
10362             case ASCII_RESTRICT_PAT_MOD:
10363                 if (flagsp == &negflags) {
10364                     goto neg_modifier;
10365                 }
10366                 if (has_charset_modifier) {
10367                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10368                         goto excess_modifier;
10369                     }
10370                     /* Doubled modifier implies more restricted */
10371                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10372                 }
10373                 else {
10374                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10375                 }
10376                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10377                 break;
10378             case DEPENDS_PAT_MOD:
10379                 if (has_use_defaults) {
10380                     goto fail_modifiers;
10381                 }
10382                 else if (flagsp == &negflags) {
10383                     goto neg_modifier;
10384                 }
10385                 else if (has_charset_modifier) {
10386                     goto excess_modifier;
10387                 }
10388
10389                 /* The dual charset means unicode semantics if the
10390                  * pattern (or target, not known until runtime) are
10391                  * utf8, or something in the pattern indicates unicode
10392                  * semantics */
10393                 cs = (RExC_utf8 || RExC_uni_semantics)
10394                      ? REGEX_UNICODE_CHARSET
10395                      : REGEX_DEPENDS_CHARSET;
10396                 has_charset_modifier = DEPENDS_PAT_MOD;
10397                 break;
10398               excess_modifier:
10399                 RExC_parse++;
10400                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10401                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10402                 }
10403                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10404                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10405                                         *(RExC_parse - 1));
10406                 }
10407                 else {
10408                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10409                 }
10410                 NOT_REACHED; /*NOTREACHED*/
10411               neg_modifier:
10412                 RExC_parse++;
10413                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10414                                     *(RExC_parse - 1));
10415                 NOT_REACHED; /*NOTREACHED*/
10416             case ONCE_PAT_MOD: /* 'o' */
10417             case GLOBAL_PAT_MOD: /* 'g' */
10418                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10419                     const I32 wflagbit = *RExC_parse == 'o'
10420                                          ? WASTED_O
10421                                          : WASTED_G;
10422                     if (! (wastedflags & wflagbit) ) {
10423                         wastedflags |= wflagbit;
10424                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10425                         vWARN5(
10426                             RExC_parse + 1,
10427                             "Useless (%s%c) - %suse /%c modifier",
10428                             flagsp == &negflags ? "?-" : "?",
10429                             *RExC_parse,
10430                             flagsp == &negflags ? "don't " : "",
10431                             *RExC_parse
10432                         );
10433                     }
10434                 }
10435                 break;
10436
10437             case CONTINUE_PAT_MOD: /* 'c' */
10438                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10439                     if (! (wastedflags & WASTED_C) ) {
10440                         wastedflags |= WASTED_GC;
10441                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10442                         vWARN3(
10443                             RExC_parse + 1,
10444                             "Useless (%sc) - %suse /gc modifier",
10445                             flagsp == &negflags ? "?-" : "?",
10446                             flagsp == &negflags ? "don't " : ""
10447                         );
10448                     }
10449                 }
10450                 break;
10451             case KEEPCOPY_PAT_MOD: /* 'p' */
10452                 if (flagsp == &negflags) {
10453                     if (PASS2)
10454                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10455                 } else {
10456                     *flagsp |= RXf_PMf_KEEPCOPY;
10457                 }
10458                 break;
10459             case '-':
10460                 /* A flag is a default iff it is following a minus, so
10461                  * if there is a minus, it means will be trying to
10462                  * re-specify a default which is an error */
10463                 if (has_use_defaults || flagsp == &negflags) {
10464                     goto fail_modifiers;
10465                 }
10466                 flagsp = &negflags;
10467                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10468                 x_mod_count = 0;
10469                 break;
10470             case ':':
10471             case ')':
10472
10473                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
10474                     negflags |= RXf_PMf_EXTENDED_MORE;
10475                 }
10476                 RExC_flags |= posflags;
10477
10478                 if (negflags & RXf_PMf_EXTENDED) {
10479                     negflags |= RXf_PMf_EXTENDED_MORE;
10480                 }
10481                 RExC_flags &= ~negflags;
10482                 set_regex_charset(&RExC_flags, cs);
10483
10484                 return;
10485             default:
10486               fail_modifiers:
10487                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10488                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10489                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10490                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10491                 NOT_REACHED; /*NOTREACHED*/
10492         }
10493
10494         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10495     }
10496
10497     vFAIL("Sequence (?... not terminated");
10498 }
10499
10500 /*
10501  - reg - regular expression, i.e. main body or parenthesized thing
10502  *
10503  * Caller must absorb opening parenthesis.
10504  *
10505  * Combining parenthesis handling with the base level of regular expression
10506  * is a trifle forced, but the need to tie the tails of the branches to what
10507  * follows makes it hard to avoid.
10508  */
10509 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10510 #ifdef DEBUGGING
10511 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10512 #else
10513 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10514 #endif
10515
10516 PERL_STATIC_INLINE regnode *
10517 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10518                              I32 *flagp,
10519                              char * parse_start,
10520                              char ch
10521                       )
10522 {
10523     regnode *ret;
10524     char* name_start = RExC_parse;
10525     U32 num = 0;
10526     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10527                                             ? REG_RSN_RETURN_NULL
10528                                             : REG_RSN_RETURN_DATA);
10529     GET_RE_DEBUG_FLAGS_DECL;
10530
10531     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10532
10533     if (RExC_parse == name_start || *RExC_parse != ch) {
10534         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10535         vFAIL2("Sequence %.3s... not terminated",parse_start);
10536     }
10537
10538     if (!SIZE_ONLY) {
10539         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10540         RExC_rxi->data->data[num]=(void*)sv_dat;
10541         SvREFCNT_inc_simple_void(sv_dat);
10542     }
10543     RExC_sawback = 1;
10544     ret = reganode(pRExC_state,
10545                    ((! FOLD)
10546                      ? NREF
10547                      : (ASCII_FOLD_RESTRICTED)
10548                        ? NREFFA
10549                        : (AT_LEAST_UNI_SEMANTICS)
10550                          ? NREFFU
10551                          : (LOC)
10552                            ? NREFFL
10553                            : NREFF),
10554                     num);
10555     *flagp |= HASWIDTH;
10556
10557     Set_Node_Offset(ret, parse_start+1);
10558     Set_Node_Cur_Length(ret, parse_start);
10559
10560     nextchar(pRExC_state);
10561     return ret;
10562 }
10563
10564 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10565    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10566    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10567    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10568    NULL, which cannot happen.  */
10569 STATIC regnode *
10570 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10571     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10572      * 2 is like 1, but indicates that nextchar() has been called to advance
10573      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10574      * this flag alerts us to the need to check for that */
10575 {
10576     regnode *ret;               /* Will be the head of the group. */
10577     regnode *br;
10578     regnode *lastbr;
10579     regnode *ender = NULL;
10580     I32 parno = 0;
10581     I32 flags;
10582     U32 oregflags = RExC_flags;
10583     bool have_branch = 0;
10584     bool is_open = 0;
10585     I32 freeze_paren = 0;
10586     I32 after_freeze = 0;
10587     I32 num; /* numeric backreferences */
10588
10589     char * parse_start = RExC_parse; /* MJD */
10590     char * const oregcomp_parse = RExC_parse;
10591
10592     GET_RE_DEBUG_FLAGS_DECL;
10593
10594     PERL_ARGS_ASSERT_REG;
10595     DEBUG_PARSE("reg ");
10596
10597     *flagp = 0;                         /* Tentatively. */
10598
10599     /* Having this true makes it feasible to have a lot fewer tests for the
10600      * parse pointer being in scope.  For example, we can write
10601      *      while(isFOO(*RExC_parse)) RExC_parse++;
10602      * instead of
10603      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10604      */
10605     assert(*RExC_end == '\0');
10606
10607     /* Make an OPEN node, if parenthesized. */
10608     if (paren) {
10609
10610         /* Under /x, space and comments can be gobbled up between the '(' and
10611          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10612          * intervening space, as the sequence is a token, and a token should be
10613          * indivisible */
10614         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
10615
10616         if (RExC_parse >= RExC_end) {
10617             vFAIL("Unmatched (");
10618         }
10619
10620         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
10621             char *start_verb = RExC_parse + 1;
10622             STRLEN verb_len;
10623             char *start_arg = NULL;
10624             unsigned char op = 0;
10625             int arg_required = 0;
10626             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10627
10628             if (has_intervening_patws) {
10629                 RExC_parse++;   /* past the '*' */
10630                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10631             }
10632             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10633                 if ( *RExC_parse == ':' ) {
10634                     start_arg = RExC_parse + 1;
10635                     break;
10636                 }
10637                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10638             }
10639             verb_len = RExC_parse - start_verb;
10640             if ( start_arg ) {
10641                 if (RExC_parse >= RExC_end) {
10642                     goto unterminated_verb_pattern;
10643                 }
10644                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10645                 while ( RExC_parse < RExC_end && *RExC_parse != ')' )
10646                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10647                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10648                   unterminated_verb_pattern:
10649                     vFAIL("Unterminated verb pattern argument");
10650                 if ( RExC_parse == start_arg )
10651                     start_arg = NULL;
10652             } else {
10653                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10654                     vFAIL("Unterminated verb pattern");
10655             }
10656
10657             /* Here, we know that RExC_parse < RExC_end */
10658
10659             switch ( *start_verb ) {
10660             case 'A':  /* (*ACCEPT) */
10661                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10662                     op = ACCEPT;
10663                     internal_argval = RExC_nestroot;
10664                 }
10665                 break;
10666             case 'C':  /* (*COMMIT) */
10667                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10668                     op = COMMIT;
10669                 break;
10670             case 'F':  /* (*FAIL) */
10671                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10672                     op = OPFAIL;
10673                 }
10674                 break;
10675             case ':':  /* (*:NAME) */
10676             case 'M':  /* (*MARK:NAME) */
10677                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10678                     op = MARKPOINT;
10679                     arg_required = 1;
10680                 }
10681                 break;
10682             case 'P':  /* (*PRUNE) */
10683                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10684                     op = PRUNE;
10685                 break;
10686             case 'S':   /* (*SKIP) */
10687                 if ( memEQs(start_verb,verb_len,"SKIP") )
10688                     op = SKIP;
10689                 break;
10690             case 'T':  /* (*THEN) */
10691                 /* [19:06] <TimToady> :: is then */
10692                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10693                     op = CUTGROUP;
10694                     RExC_seen |= REG_CUTGROUP_SEEN;
10695                 }
10696                 break;
10697             }
10698             if ( ! op ) {
10699                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10700                 vFAIL2utf8f(
10701                     "Unknown verb pattern '%" UTF8f "'",
10702                     UTF8fARG(UTF, verb_len, start_verb));
10703             }
10704             if ( arg_required && !start_arg ) {
10705                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
10706                     verb_len, start_verb);
10707             }
10708             if (internal_argval == -1) {
10709                 ret = reganode(pRExC_state, op, 0);
10710             } else {
10711                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
10712             }
10713             RExC_seen |= REG_VERBARG_SEEN;
10714             if ( ! SIZE_ONLY ) {
10715                 if (start_arg) {
10716                     SV *sv = newSVpvn( start_arg,
10717                                        RExC_parse - start_arg);
10718                     ARG(ret) = add_data( pRExC_state,
10719                                          STR_WITH_LEN("S"));
10720                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
10721                     ret->flags = 1;
10722                 } else {
10723                     ret->flags = 0;
10724                 }
10725                 if ( internal_argval != -1 )
10726                     ARG2L_SET(ret, internal_argval);
10727             }
10728             nextchar(pRExC_state);
10729             return ret;
10730         }
10731         else if (*RExC_parse == '?') { /* (?...) */
10732             bool is_logical = 0;
10733             const char * const seqstart = RExC_parse;
10734             const char * endptr;
10735             if (has_intervening_patws) {
10736                 RExC_parse++;
10737                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
10738             }
10739
10740             RExC_parse++;           /* past the '?' */
10741             paren = *RExC_parse;    /* might be a trailing NUL, if not
10742                                        well-formed */
10743             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10744             if (RExC_parse > RExC_end) {
10745                 paren = '\0';
10746             }
10747             ret = NULL;                 /* For look-ahead/behind. */
10748             switch (paren) {
10749
10750             case 'P':   /* (?P...) variants for those used to PCRE/Python */
10751                 paren = *RExC_parse;
10752                 if ( paren == '<') {    /* (?P<...>) named capture */
10753                     RExC_parse++;
10754                     if (RExC_parse >= RExC_end) {
10755                         vFAIL("Sequence (?P<... not terminated");
10756                     }
10757                     goto named_capture;
10758                 }
10759                 else if (paren == '>') {   /* (?P>name) named recursion */
10760                     RExC_parse++;
10761                     if (RExC_parse >= RExC_end) {
10762                         vFAIL("Sequence (?P>... not terminated");
10763                     }
10764                     goto named_recursion;
10765                 }
10766                 else if (paren == '=') {   /* (?P=...)  named backref */
10767                     RExC_parse++;
10768                     return handle_named_backref(pRExC_state, flagp,
10769                                                 parse_start, ')');
10770                 }
10771                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10772                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10773                 vFAIL3("Sequence (%.*s...) not recognized",
10774                                 RExC_parse-seqstart, seqstart);
10775                 NOT_REACHED; /*NOTREACHED*/
10776             case '<':           /* (?<...) */
10777                 if (*RExC_parse == '!')
10778                     paren = ',';
10779                 else if (*RExC_parse != '=')
10780               named_capture:
10781                 {               /* (?<...>) */
10782                     char *name_start;
10783                     SV *svname;
10784                     paren= '>';
10785                 /* FALLTHROUGH */
10786             case '\'':          /* (?'...') */
10787                     name_start = RExC_parse;
10788                     svname = reg_scan_name(pRExC_state,
10789                         SIZE_ONLY    /* reverse test from the others */
10790                         ? REG_RSN_RETURN_NAME
10791                         : REG_RSN_RETURN_NULL);
10792                     if (   RExC_parse == name_start
10793                         || RExC_parse >= RExC_end
10794                         || *RExC_parse != paren)
10795                     {
10796                         vFAIL2("Sequence (?%c... not terminated",
10797                             paren=='>' ? '<' : paren);
10798                     }
10799                     if (SIZE_ONLY) {
10800                         HE *he_str;
10801                         SV *sv_dat = NULL;
10802                         if (!svname) /* shouldn't happen */
10803                             Perl_croak(aTHX_
10804                                 "panic: reg_scan_name returned NULL");
10805                         if (!RExC_paren_names) {
10806                             RExC_paren_names= newHV();
10807                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10808 #ifdef DEBUGGING
10809                             RExC_paren_name_list= newAV();
10810                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10811 #endif
10812                         }
10813                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10814                         if ( he_str )
10815                             sv_dat = HeVAL(he_str);
10816                         if ( ! sv_dat ) {
10817                             /* croak baby croak */
10818                             Perl_croak(aTHX_
10819                                 "panic: paren_name hash element allocation failed");
10820                         } else if ( SvPOK(sv_dat) ) {
10821                             /* (?|...) can mean we have dupes so scan to check
10822                                its already been stored. Maybe a flag indicating
10823                                we are inside such a construct would be useful,
10824                                but the arrays are likely to be quite small, so
10825                                for now we punt -- dmq */
10826                             IV count = SvIV(sv_dat);
10827                             I32 *pv = (I32*)SvPVX(sv_dat);
10828                             IV i;
10829                             for ( i = 0 ; i < count ; i++ ) {
10830                                 if ( pv[i] == RExC_npar ) {
10831                                     count = 0;
10832                                     break;
10833                                 }
10834                             }
10835                             if ( count ) {
10836                                 pv = (I32*)SvGROW(sv_dat,
10837                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10838                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10839                                 pv[count] = RExC_npar;
10840                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10841                             }
10842                         } else {
10843                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10844                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10845                                                                 sizeof(I32));
10846                             SvIOK_on(sv_dat);
10847                             SvIV_set(sv_dat, 1);
10848                         }
10849 #ifdef DEBUGGING
10850                         /* Yes this does cause a memory leak in debugging Perls
10851                          * */
10852                         if (!av_store(RExC_paren_name_list,
10853                                       RExC_npar, SvREFCNT_inc(svname)))
10854                             SvREFCNT_dec_NN(svname);
10855 #endif
10856
10857                         /*sv_dump(sv_dat);*/
10858                     }
10859                     nextchar(pRExC_state);
10860                     paren = 1;
10861                     goto capturing_parens;
10862                 }
10863                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10864                 RExC_in_lookbehind++;
10865                 RExC_parse++;
10866                 if (RExC_parse >= RExC_end) {
10867                     vFAIL("Sequence (?... not terminated");
10868                 }
10869
10870                 /* FALLTHROUGH */
10871             case '=':           /* (?=...) */
10872                 RExC_seen_zerolen++;
10873                 break;
10874             case '!':           /* (?!...) */
10875                 RExC_seen_zerolen++;
10876                 /* check if we're really just a "FAIL" assertion */
10877                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
10878                                         FALSE /* Don't force to /x */ );
10879                 if (*RExC_parse == ')') {
10880                     ret=reganode(pRExC_state, OPFAIL, 0);
10881                     nextchar(pRExC_state);
10882                     return ret;
10883                 }
10884                 break;
10885             case '|':           /* (?|...) */
10886                 /* branch reset, behave like a (?:...) except that
10887                    buffers in alternations share the same numbers */
10888                 paren = ':';
10889                 after_freeze = freeze_paren = RExC_npar;
10890                 break;
10891             case ':':           /* (?:...) */
10892             case '>':           /* (?>...) */
10893                 break;
10894             case '$':           /* (?$...) */
10895             case '@':           /* (?@...) */
10896                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10897                 break;
10898             case '0' :           /* (?0) */
10899             case 'R' :           /* (?R) */
10900                 if (RExC_parse == RExC_end || *RExC_parse != ')')
10901                     FAIL("Sequence (?R) not terminated");
10902                 num = 0;
10903                 RExC_seen |= REG_RECURSE_SEEN;
10904                 *flagp |= POSTPONED;
10905                 goto gen_recurse_regop;
10906                 /*notreached*/
10907             /* named and numeric backreferences */
10908             case '&':            /* (?&NAME) */
10909                 parse_start = RExC_parse - 1;
10910               named_recursion:
10911                 {
10912                     SV *sv_dat = reg_scan_name(pRExC_state,
10913                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10914                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10915                 }
10916                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
10917                     vFAIL("Sequence (?&... not terminated");
10918                 goto gen_recurse_regop;
10919                 /* NOTREACHED */
10920             case '+':
10921                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10922                     RExC_parse++;
10923                     vFAIL("Illegal pattern");
10924                 }
10925                 goto parse_recursion;
10926                 /* NOTREACHED*/
10927             case '-': /* (?-1) */
10928                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10929                     RExC_parse--; /* rewind to let it be handled later */
10930                     goto parse_flags;
10931                 }
10932                 /* FALLTHROUGH */
10933             case '1': case '2': case '3': case '4': /* (?1) */
10934             case '5': case '6': case '7': case '8': case '9':
10935                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
10936               parse_recursion:
10937                 {
10938                     bool is_neg = FALSE;
10939                     UV unum;
10940                     parse_start = RExC_parse - 1; /* MJD */
10941                     if (*RExC_parse == '-') {
10942                         RExC_parse++;
10943                         is_neg = TRUE;
10944                     }
10945                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10946                         && unum <= I32_MAX
10947                     ) {
10948                         num = (I32)unum;
10949                         RExC_parse = (char*)endptr;
10950                     } else
10951                         num = I32_MAX;
10952                     if (is_neg) {
10953                         /* Some limit for num? */
10954                         num = -num;
10955                     }
10956                 }
10957                 if (*RExC_parse!=')')
10958                     vFAIL("Expecting close bracket");
10959
10960               gen_recurse_regop:
10961                 if ( paren == '-' ) {
10962                     /*
10963                     Diagram of capture buffer numbering.
10964                     Top line is the normal capture buffer numbers
10965                     Bottom line is the negative indexing as from
10966                     the X (the (?-2))
10967
10968                     +   1 2    3 4 5 X          6 7
10969                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
10970                     -   5 4    3 2 1 X          x x
10971
10972                     */
10973                     num = RExC_npar + num;
10974                     if (num < 1)  {
10975                         RExC_parse++;
10976                         vFAIL("Reference to nonexistent group");
10977                     }
10978                 } else if ( paren == '+' ) {
10979                     num = RExC_npar + num - 1;
10980                 }
10981                 /* We keep track how many GOSUB items we have produced.
10982                    To start off the ARG2L() of the GOSUB holds its "id",
10983                    which is used later in conjunction with RExC_recurse
10984                    to calculate the offset we need to jump for the GOSUB,
10985                    which it will store in the final representation.
10986                    We have to defer the actual calculation until much later
10987                    as the regop may move.
10988                  */
10989
10990                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
10991                 if (!SIZE_ONLY) {
10992                     if (num > (I32)RExC_rx->nparens) {
10993                         RExC_parse++;
10994                         vFAIL("Reference to nonexistent group");
10995                     }
10996                     RExC_recurse_count++;
10997                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
10998                         "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
10999                               22, "|    |", (int)(depth * 2 + 1), "",
11000                               (UV)ARG(ret), (IV)ARG2L(ret)));
11001                 }
11002                 RExC_seen |= REG_RECURSE_SEEN;
11003
11004                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
11005                 Set_Node_Offset(ret, parse_start); /* MJD */
11006
11007                 *flagp |= POSTPONED;
11008                 assert(*RExC_parse == ')');
11009                 nextchar(pRExC_state);
11010                 return ret;
11011
11012             /* NOTREACHED */
11013
11014             case '?':           /* (??...) */
11015                 is_logical = 1;
11016                 if (*RExC_parse != '{') {
11017                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
11018                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11019                     vFAIL2utf8f(
11020                         "Sequence (%" UTF8f "...) not recognized",
11021                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11022                     NOT_REACHED; /*NOTREACHED*/
11023                 }
11024                 *flagp |= POSTPONED;
11025                 paren = '{';
11026                 RExC_parse++;
11027                 /* FALLTHROUGH */
11028             case '{':           /* (?{...}) */
11029             {
11030                 U32 n = 0;
11031                 struct reg_code_block *cb;
11032
11033                 RExC_seen_zerolen++;
11034
11035                 if (   !pRExC_state->code_blocks
11036                     || pRExC_state->code_index
11037                                         >= pRExC_state->code_blocks->count
11038                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11039                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11040                             - RExC_start)
11041                 ) {
11042                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11043                         FAIL("panic: Sequence (?{...}): no code block found\n");
11044                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11045                 }
11046                 /* this is a pre-compiled code block (?{...}) */
11047                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11048                 RExC_parse = RExC_start + cb->end;
11049                 if (!SIZE_ONLY) {
11050                     OP *o = cb->block;
11051                     if (cb->src_regex) {
11052                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11053                         RExC_rxi->data->data[n] =
11054                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
11055                         RExC_rxi->data->data[n+1] = (void*)o;
11056                     }
11057                     else {
11058                         n = add_data(pRExC_state,
11059                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11060                         RExC_rxi->data->data[n] = (void*)o;
11061                     }
11062                 }
11063                 pRExC_state->code_index++;
11064                 nextchar(pRExC_state);
11065
11066                 if (is_logical) {
11067                     regnode *eval;
11068                     ret = reg_node(pRExC_state, LOGICAL);
11069
11070                     eval = reg2Lanode(pRExC_state, EVAL,
11071                                        n,
11072
11073                                        /* for later propagation into (??{})
11074                                         * return value */
11075                                        RExC_flags & RXf_PMf_COMPILETIME
11076                                       );
11077                     if (!SIZE_ONLY) {
11078                         ret->flags = 2;
11079                     }
11080                     REGTAIL(pRExC_state, ret, eval);
11081                     /* deal with the length of this later - MJD */
11082                     return ret;
11083                 }
11084                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11085                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
11086                 Set_Node_Offset(ret, parse_start);
11087                 return ret;
11088             }
11089             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11090             {
11091                 int is_define= 0;
11092                 const int DEFINE_len = sizeof("DEFINE") - 1;
11093                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
11094                     if (   RExC_parse < RExC_end - 1
11095                         && (   RExC_parse[1] == '='
11096                             || RExC_parse[1] == '!'
11097                             || RExC_parse[1] == '<'
11098                             || RExC_parse[1] == '{')
11099                     ) { /* Lookahead or eval. */
11100                         I32 flag;
11101                         regnode *tail;
11102
11103                         ret = reg_node(pRExC_state, LOGICAL);
11104                         if (!SIZE_ONLY)
11105                             ret->flags = 1;
11106
11107                         tail = reg(pRExC_state, 1, &flag, depth+1);
11108                         if (flag & (RESTART_PASS1|NEED_UTF8)) {
11109                             *flagp = flag & (RESTART_PASS1|NEED_UTF8);
11110                             return NULL;
11111                         }
11112                         REGTAIL(pRExC_state, ret, tail);
11113                         goto insert_if;
11114                     }
11115                     /* Fall through to ‘Unknown switch condition’ at the
11116                        end of the if/else chain. */
11117                 }
11118                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11119                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11120                 {
11121                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11122                     char *name_start= RExC_parse++;
11123                     U32 num = 0;
11124                     SV *sv_dat=reg_scan_name(pRExC_state,
11125                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11126                     if (   RExC_parse == name_start
11127                         || RExC_parse >= RExC_end
11128                         || *RExC_parse != ch)
11129                     {
11130                         vFAIL2("Sequence (?(%c... not terminated",
11131                             (ch == '>' ? '<' : ch));
11132                     }
11133                     RExC_parse++;
11134                     if (!SIZE_ONLY) {
11135                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11136                         RExC_rxi->data->data[num]=(void*)sv_dat;
11137                         SvREFCNT_inc_simple_void(sv_dat);
11138                     }
11139                     ret = reganode(pRExC_state,NGROUPP,num);
11140                     goto insert_if_check_paren;
11141                 }
11142                 else if (RExC_end - RExC_parse >= DEFINE_len
11143                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
11144                 {
11145                     ret = reganode(pRExC_state,DEFINEP,0);
11146                     RExC_parse += DEFINE_len;
11147                     is_define = 1;
11148                     goto insert_if_check_paren;
11149                 }
11150                 else if (RExC_parse[0] == 'R') {
11151                     RExC_parse++;
11152                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11153                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11154                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11155                      */
11156                     parno = 0;
11157                     if (RExC_parse[0] == '0') {
11158                         parno = 1;
11159                         RExC_parse++;
11160                     }
11161                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11162                         UV uv;
11163                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11164                             && uv <= I32_MAX
11165                         ) {
11166                             parno = (I32)uv + 1;
11167                             RExC_parse = (char*)endptr;
11168                         }
11169                         /* else "Switch condition not recognized" below */
11170                     } else if (RExC_parse[0] == '&') {
11171                         SV *sv_dat;
11172                         RExC_parse++;
11173                         sv_dat = reg_scan_name(pRExC_state,
11174                             SIZE_ONLY
11175                             ? REG_RSN_RETURN_NULL
11176                             : REG_RSN_RETURN_DATA);
11177
11178                         /* we should only have a false sv_dat when
11179                          * SIZE_ONLY is true, and we always have false
11180                          * sv_dat when SIZE_ONLY is true.
11181                          * reg_scan_name() will VFAIL() if the name is
11182                          * unknown when SIZE_ONLY is false, and otherwise
11183                          * will return something, and when SIZE_ONLY is
11184                          * true, reg_scan_name() just parses the string,
11185                          * and doesnt return anything. (in theory) */
11186                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
11187
11188                         if (sv_dat)
11189                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11190                     }
11191                     ret = reganode(pRExC_state,INSUBP,parno);
11192                     goto insert_if_check_paren;
11193                 }
11194                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11195                     /* (?(1)...) */
11196                     char c;
11197                     UV uv;
11198                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11199                         && uv <= I32_MAX
11200                     ) {
11201                         parno = (I32)uv;
11202                         RExC_parse = (char*)endptr;
11203                     }
11204                     else {
11205                         vFAIL("panic: grok_atoUV returned FALSE");
11206                     }
11207                     ret = reganode(pRExC_state, GROUPP, parno);
11208
11209                  insert_if_check_paren:
11210                     if (UCHARAT(RExC_parse) != ')') {
11211                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11212                         vFAIL("Switch condition not recognized");
11213                     }
11214                     nextchar(pRExC_state);
11215                   insert_if:
11216                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11217                     br = regbranch(pRExC_state, &flags, 1,depth+1);
11218                     if (br == NULL) {
11219                         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11220                             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11221                             return NULL;
11222                         }
11223                         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11224                               (UV) flags);
11225                     } else
11226                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11227                                                           LONGJMP, 0));
11228                     c = UCHARAT(RExC_parse);
11229                     nextchar(pRExC_state);
11230                     if (flags&HASWIDTH)
11231                         *flagp |= HASWIDTH;
11232                     if (c == '|') {
11233                         if (is_define)
11234                             vFAIL("(?(DEFINE)....) does not allow branches");
11235
11236                         /* Fake one for optimizer.  */
11237                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11238
11239                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
11240                             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11241                                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11242                                 return NULL;
11243                             }
11244                             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11245                                   (UV) flags);
11246                         }
11247                         REGTAIL(pRExC_state, ret, lastbr);
11248                         if (flags&HASWIDTH)
11249                             *flagp |= HASWIDTH;
11250                         c = UCHARAT(RExC_parse);
11251                         nextchar(pRExC_state);
11252                     }
11253                     else
11254                         lastbr = NULL;
11255                     if (c != ')') {
11256                         if (RExC_parse >= RExC_end)
11257                             vFAIL("Switch (?(condition)... not terminated");
11258                         else
11259                             vFAIL("Switch (?(condition)... contains too many branches");
11260                     }
11261                     ender = reg_node(pRExC_state, TAIL);
11262                     REGTAIL(pRExC_state, br, ender);
11263                     if (lastbr) {
11264                         REGTAIL(pRExC_state, lastbr, ender);
11265                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11266                     }
11267                     else
11268                         REGTAIL(pRExC_state, ret, ender);
11269                     RExC_size++; /* XXX WHY do we need this?!!
11270                                     For large programs it seems to be required
11271                                     but I can't figure out why. -- dmq*/
11272                     return ret;
11273                 }
11274                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11275                 vFAIL("Unknown switch condition (?(...))");
11276             }
11277             case '[':           /* (?[ ... ]) */
11278                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
11279                                          oregcomp_parse);
11280             case 0: /* A NUL */
11281                 RExC_parse--; /* for vFAIL to print correctly */
11282                 vFAIL("Sequence (? incomplete");
11283                 break;
11284             default: /* e.g., (?i) */
11285                 RExC_parse = (char *) seqstart + 1;
11286               parse_flags:
11287                 parse_lparen_question_flags(pRExC_state);
11288                 if (UCHARAT(RExC_parse) != ':') {
11289                     if (RExC_parse < RExC_end)
11290                         nextchar(pRExC_state);
11291                     *flagp = TRYAGAIN;
11292                     return NULL;
11293                 }
11294                 paren = ':';
11295                 nextchar(pRExC_state);
11296                 ret = NULL;
11297                 goto parse_rest;
11298             } /* end switch */
11299         }
11300         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11301           capturing_parens:
11302             parno = RExC_npar;
11303             RExC_npar++;
11304
11305             ret = reganode(pRExC_state, OPEN, parno);
11306             if (!SIZE_ONLY ){
11307                 if (!RExC_nestroot)
11308                     RExC_nestroot = parno;
11309                 if (RExC_open_parens && !RExC_open_parens[parno])
11310                 {
11311                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11312                         "%*s%*s Setting open paren #%" IVdf " to %d\n",
11313                         22, "|    |", (int)(depth * 2 + 1), "",
11314                         (IV)parno, REG_NODE_NUM(ret)));
11315                     RExC_open_parens[parno]= ret;
11316                 }
11317             }
11318             Set_Node_Length(ret, 1); /* MJD */
11319             Set_Node_Offset(ret, RExC_parse); /* MJD */
11320             is_open = 1;
11321         } else {
11322             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11323             paren = ':';
11324             ret = NULL;
11325         }
11326     }
11327     else                        /* ! paren */
11328         ret = NULL;
11329
11330    parse_rest:
11331     /* Pick up the branches, linking them together. */
11332     parse_start = RExC_parse;   /* MJD */
11333     br = regbranch(pRExC_state, &flags, 1,depth+1);
11334
11335     /*     branch_len = (paren != 0); */
11336
11337     if (br == NULL) {
11338         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11339             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11340             return NULL;
11341         }
11342         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11343     }
11344     if (*RExC_parse == '|') {
11345         if (!SIZE_ONLY && RExC_extralen) {
11346             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11347         }
11348         else {                  /* MJD */
11349             reginsert(pRExC_state, BRANCH, br, depth+1);
11350             Set_Node_Length(br, paren != 0);
11351             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11352         }
11353         have_branch = 1;
11354         if (SIZE_ONLY)
11355             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11356     }
11357     else if (paren == ':') {
11358         *flagp |= flags&SIMPLE;
11359     }
11360     if (is_open) {                              /* Starts with OPEN. */
11361         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11362     }
11363     else if (paren != '?')              /* Not Conditional */
11364         ret = br;
11365     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11366     lastbr = br;
11367     while (*RExC_parse == '|') {
11368         if (!SIZE_ONLY && RExC_extralen) {
11369             ender = reganode(pRExC_state, LONGJMP,0);
11370
11371             /* Append to the previous. */
11372             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11373         }
11374         if (SIZE_ONLY)
11375             RExC_extralen += 2;         /* Account for LONGJMP. */
11376         nextchar(pRExC_state);
11377         if (freeze_paren) {
11378             if (RExC_npar > after_freeze)
11379                 after_freeze = RExC_npar;
11380             RExC_npar = freeze_paren;
11381         }
11382         br = regbranch(pRExC_state, &flags, 0, depth+1);
11383
11384         if (br == NULL) {
11385             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11386                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11387                 return NULL;
11388             }
11389             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11390         }
11391         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11392         lastbr = br;
11393         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11394     }
11395
11396     if (have_branch || paren != ':') {
11397         /* Make a closing node, and hook it on the end. */
11398         switch (paren) {
11399         case ':':
11400             ender = reg_node(pRExC_state, TAIL);
11401             break;
11402         case 1: case 2:
11403             ender = reganode(pRExC_state, CLOSE, parno);
11404             if ( RExC_close_parens ) {
11405                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11406                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
11407                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11408                 RExC_close_parens[parno]= ender;
11409                 if (RExC_nestroot == parno)
11410                     RExC_nestroot = 0;
11411             }
11412             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11413             Set_Node_Length(ender,1); /* MJD */
11414             break;
11415         case '<':
11416         case ',':
11417         case '=':
11418         case '!':
11419             *flagp &= ~HASWIDTH;
11420             /* FALLTHROUGH */
11421         case '>':
11422             ender = reg_node(pRExC_state, SUCCEED);
11423             break;
11424         case 0:
11425             ender = reg_node(pRExC_state, END);
11426             if (!SIZE_ONLY) {
11427                 assert(!RExC_end_op); /* there can only be one! */
11428                 RExC_end_op = ender;
11429                 if (RExC_close_parens) {
11430                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11431                         "%*s%*s Setting close paren #0 (END) to %d\n",
11432                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11433
11434                     RExC_close_parens[0]= ender;
11435                 }
11436             }
11437             break;
11438         }
11439         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11440             DEBUG_PARSE_MSG("lsbr");
11441             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11442             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11443             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11444                           SvPV_nolen_const(RExC_mysv1),
11445                           (IV)REG_NODE_NUM(lastbr),
11446                           SvPV_nolen_const(RExC_mysv2),
11447                           (IV)REG_NODE_NUM(ender),
11448                           (IV)(ender - lastbr)
11449             );
11450         });
11451         REGTAIL(pRExC_state, lastbr, ender);
11452
11453         if (have_branch && !SIZE_ONLY) {
11454             char is_nothing= 1;
11455             if (depth==1)
11456                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11457
11458             /* Hook the tails of the branches to the closing node. */
11459             for (br = ret; br; br = regnext(br)) {
11460                 const U8 op = PL_regkind[OP(br)];
11461                 if (op == BRANCH) {
11462                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11463                     if ( OP(NEXTOPER(br)) != NOTHING
11464                          || regnext(NEXTOPER(br)) != ender)
11465                         is_nothing= 0;
11466                 }
11467                 else if (op == BRANCHJ) {
11468                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11469                     /* for now we always disable this optimisation * /
11470                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11471                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11472                     */
11473                         is_nothing= 0;
11474                 }
11475             }
11476             if (is_nothing) {
11477                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11478                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11479                     DEBUG_PARSE_MSG("NADA");
11480                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11481                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11482                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11483                                   SvPV_nolen_const(RExC_mysv1),
11484                                   (IV)REG_NODE_NUM(ret),
11485                                   SvPV_nolen_const(RExC_mysv2),
11486                                   (IV)REG_NODE_NUM(ender),
11487                                   (IV)(ender - ret)
11488                     );
11489                 });
11490                 OP(br)= NOTHING;
11491                 if (OP(ender) == TAIL) {
11492                     NEXT_OFF(br)= 0;
11493                     RExC_emit= br + 1;
11494                 } else {
11495                     regnode *opt;
11496                     for ( opt= br + 1; opt < ender ; opt++ )
11497                         OP(opt)= OPTIMIZED;
11498                     NEXT_OFF(br)= ender - br;
11499                 }
11500             }
11501         }
11502     }
11503
11504     {
11505         const char *p;
11506         static const char parens[] = "=!<,>";
11507
11508         if (paren && (p = strchr(parens, paren))) {
11509             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11510             int flag = (p - parens) > 1;
11511
11512             if (paren == '>')
11513                 node = SUSPEND, flag = 0;
11514             reginsert(pRExC_state, node,ret, depth+1);
11515             Set_Node_Cur_Length(ret, parse_start);
11516             Set_Node_Offset(ret, parse_start + 1);
11517             ret->flags = flag;
11518             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11519         }
11520     }
11521
11522     /* Check for proper termination. */
11523     if (paren) {
11524         /* restore original flags, but keep (?p) and, if we've changed from /d
11525          * rules to /u, keep the /u */
11526         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11527         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11528             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11529         }
11530         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11531             RExC_parse = oregcomp_parse;
11532             vFAIL("Unmatched (");
11533         }
11534         nextchar(pRExC_state);
11535     }
11536     else if (!paren && RExC_parse < RExC_end) {
11537         if (*RExC_parse == ')') {
11538             RExC_parse++;
11539             vFAIL("Unmatched )");
11540         }
11541         else
11542             FAIL("Junk on end of regexp");      /* "Can't happen". */
11543         NOT_REACHED; /* NOTREACHED */
11544     }
11545
11546     if (RExC_in_lookbehind) {
11547         RExC_in_lookbehind--;
11548     }
11549     if (after_freeze > RExC_npar)
11550         RExC_npar = after_freeze;
11551     return(ret);
11552 }
11553
11554 /*
11555  - regbranch - one alternative of an | operator
11556  *
11557  * Implements the concatenation operator.
11558  *
11559  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11560  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11561  */
11562 STATIC regnode *
11563 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11564 {
11565     regnode *ret;
11566     regnode *chain = NULL;
11567     regnode *latest;
11568     I32 flags = 0, c = 0;
11569     GET_RE_DEBUG_FLAGS_DECL;
11570
11571     PERL_ARGS_ASSERT_REGBRANCH;
11572
11573     DEBUG_PARSE("brnc");
11574
11575     if (first)
11576         ret = NULL;
11577     else {
11578         if (!SIZE_ONLY && RExC_extralen)
11579             ret = reganode(pRExC_state, BRANCHJ,0);
11580         else {
11581             ret = reg_node(pRExC_state, BRANCH);
11582             Set_Node_Length(ret, 1);
11583         }
11584     }
11585
11586     if (!first && SIZE_ONLY)
11587         RExC_extralen += 1;                     /* BRANCHJ */
11588
11589     *flagp = WORST;                     /* Tentatively. */
11590
11591     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11592                             FALSE /* Don't force to /x */ );
11593     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11594         flags &= ~TRYAGAIN;
11595         latest = regpiece(pRExC_state, &flags,depth+1);
11596         if (latest == NULL) {
11597             if (flags & TRYAGAIN)
11598                 continue;
11599             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11600                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11601                 return NULL;
11602             }
11603             FAIL2("panic: regpiece returned NULL, flags=%#" UVxf, (UV) flags);
11604         }
11605         else if (ret == NULL)
11606             ret = latest;
11607         *flagp |= flags&(HASWIDTH|POSTPONED);
11608         if (chain == NULL)      /* First piece. */
11609             *flagp |= flags&SPSTART;
11610         else {
11611             /* FIXME adding one for every branch after the first is probably
11612              * excessive now we have TRIE support. (hv) */
11613             MARK_NAUGHTY(1);
11614             REGTAIL(pRExC_state, chain, latest);
11615         }
11616         chain = latest;
11617         c++;
11618     }
11619     if (chain == NULL) {        /* Loop ran zero times. */
11620         chain = reg_node(pRExC_state, NOTHING);
11621         if (ret == NULL)
11622             ret = chain;
11623     }
11624     if (c == 1) {
11625         *flagp |= flags&SIMPLE;
11626     }
11627
11628     return ret;
11629 }
11630
11631 /*
11632  - regpiece - something followed by possible quantifier * + ? {n,m}
11633  *
11634  * Note that the branching code sequences used for ? and the general cases
11635  * of * and + are somewhat optimized:  they use the same NOTHING node as
11636  * both the endmarker for their branch list and the body of the last branch.
11637  * It might seem that this node could be dispensed with entirely, but the
11638  * endmarker role is not redundant.
11639  *
11640  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11641  * TRYAGAIN.
11642  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11643  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11644  */
11645 STATIC regnode *
11646 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11647 {
11648     regnode *ret;
11649     char op;
11650     char *next;
11651     I32 flags;
11652     const char * const origparse = RExC_parse;
11653     I32 min;
11654     I32 max = REG_INFTY;
11655 #ifdef RE_TRACK_PATTERN_OFFSETS
11656     char *parse_start;
11657 #endif
11658     const char *maxpos = NULL;
11659     UV uv;
11660
11661     /* Save the original in case we change the emitted regop to a FAIL. */
11662     regnode * const orig_emit = RExC_emit;
11663
11664     GET_RE_DEBUG_FLAGS_DECL;
11665
11666     PERL_ARGS_ASSERT_REGPIECE;
11667
11668     DEBUG_PARSE("piec");
11669
11670     ret = regatom(pRExC_state, &flags,depth+1);
11671     if (ret == NULL) {
11672         if (flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8))
11673             *flagp |= flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8);
11674         else
11675             FAIL2("panic: regatom returned NULL, flags=%#" UVxf, (UV) flags);
11676         return(NULL);
11677     }
11678
11679     op = *RExC_parse;
11680
11681     if (op == '{' && regcurly(RExC_parse)) {
11682         maxpos = NULL;
11683 #ifdef RE_TRACK_PATTERN_OFFSETS
11684         parse_start = RExC_parse; /* MJD */
11685 #endif
11686         next = RExC_parse + 1;
11687         while (isDIGIT(*next) || *next == ',') {
11688             if (*next == ',') {
11689                 if (maxpos)
11690                     break;
11691                 else
11692                     maxpos = next;
11693             }
11694             next++;
11695         }
11696         if (*next == '}') {             /* got one */
11697             const char* endptr;
11698             if (!maxpos)
11699                 maxpos = next;
11700             RExC_parse++;
11701             if (isDIGIT(*RExC_parse)) {
11702                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
11703                     vFAIL("Invalid quantifier in {,}");
11704                 if (uv >= REG_INFTY)
11705                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11706                 min = (I32)uv;
11707             } else {
11708                 min = 0;
11709             }
11710             if (*maxpos == ',')
11711                 maxpos++;
11712             else
11713                 maxpos = RExC_parse;
11714             if (isDIGIT(*maxpos)) {
11715                 if (!grok_atoUV(maxpos, &uv, &endptr))
11716                     vFAIL("Invalid quantifier in {,}");
11717                 if (uv >= REG_INFTY)
11718                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11719                 max = (I32)uv;
11720             } else {
11721                 max = REG_INFTY;                /* meaning "infinity" */
11722             }
11723             RExC_parse = next;
11724             nextchar(pRExC_state);
11725             if (max < min) {    /* If can't match, warn and optimize to fail
11726                                    unconditionally */
11727                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
11728                 if (PASS2) {
11729                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
11730                     NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
11731                 }
11732                 return ret;
11733             }
11734             else if (min == max && *RExC_parse == '?')
11735             {
11736                 if (PASS2) {
11737                     ckWARN2reg(RExC_parse + 1,
11738                                "Useless use of greediness modifier '%c'",
11739                                *RExC_parse);
11740                 }
11741             }
11742
11743           do_curly:
11744             if ((flags&SIMPLE)) {
11745                 if (min == 0 && max == REG_INFTY) {
11746                     reginsert(pRExC_state, STAR, ret, depth+1);
11747                     ret->flags = 0;
11748                     MARK_NAUGHTY(4);
11749                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11750                     goto nest_check;
11751                 }
11752                 if (min == 1 && max == REG_INFTY) {
11753                     reginsert(pRExC_state, PLUS, ret, depth+1);
11754                     ret->flags = 0;
11755                     MARK_NAUGHTY(3);
11756                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11757                     goto nest_check;
11758                 }
11759                 MARK_NAUGHTY_EXP(2, 2);
11760                 reginsert(pRExC_state, CURLY, ret, depth+1);
11761                 Set_Node_Offset(ret, parse_start+1); /* MJD */
11762                 Set_Node_Cur_Length(ret, parse_start);
11763             }
11764             else {
11765                 regnode * const w = reg_node(pRExC_state, WHILEM);
11766
11767                 w->flags = 0;
11768                 REGTAIL(pRExC_state, ret, w);
11769                 if (!SIZE_ONLY && RExC_extralen) {
11770                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
11771                     reginsert(pRExC_state, NOTHING,ret, depth+1);
11772                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
11773                 }
11774                 reginsert(pRExC_state, CURLYX,ret, depth+1);
11775                                 /* MJD hk */
11776                 Set_Node_Offset(ret, parse_start+1);
11777                 Set_Node_Length(ret,
11778                                 op == '{' ? (RExC_parse - parse_start) : 1);
11779
11780                 if (!SIZE_ONLY && RExC_extralen)
11781                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
11782                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
11783                 if (SIZE_ONLY)
11784                     RExC_whilem_seen++, RExC_extralen += 3;
11785                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
11786             }
11787             ret->flags = 0;
11788
11789             if (min > 0)
11790                 *flagp = WORST;
11791             if (max > 0)
11792                 *flagp |= HASWIDTH;
11793             if (!SIZE_ONLY) {
11794                 ARG1_SET(ret, (U16)min);
11795                 ARG2_SET(ret, (U16)max);
11796             }
11797             if (max == REG_INFTY)
11798                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11799
11800             goto nest_check;
11801         }
11802     }
11803
11804     if (!ISMULT1(op)) {
11805         *flagp = flags;
11806         return(ret);
11807     }
11808
11809 #if 0                           /* Now runtime fix should be reliable. */
11810
11811     /* if this is reinstated, don't forget to put this back into perldiag:
11812
11813             =item Regexp *+ operand could be empty at {#} in regex m/%s/
11814
11815            (F) The part of the regexp subject to either the * or + quantifier
11816            could match an empty string. The {#} shows in the regular
11817            expression about where the problem was discovered.
11818
11819     */
11820
11821     if (!(flags&HASWIDTH) && op != '?')
11822       vFAIL("Regexp *+ operand could be empty");
11823 #endif
11824
11825 #ifdef RE_TRACK_PATTERN_OFFSETS
11826     parse_start = RExC_parse;
11827 #endif
11828     nextchar(pRExC_state);
11829
11830     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
11831
11832     if (op == '*') {
11833         min = 0;
11834         goto do_curly;
11835     }
11836     else if (op == '+') {
11837         min = 1;
11838         goto do_curly;
11839     }
11840     else if (op == '?') {
11841         min = 0; max = 1;
11842         goto do_curly;
11843     }
11844   nest_check:
11845     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
11846         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11847         ckWARN2reg(RExC_parse,
11848                    "%" UTF8f " matches null string many times",
11849                    UTF8fARG(UTF, (RExC_parse >= origparse
11850                                  ? RExC_parse - origparse
11851                                  : 0),
11852                    origparse));
11853         (void)ReREFCNT_inc(RExC_rx_sv);
11854     }
11855
11856     if (*RExC_parse == '?') {
11857         nextchar(pRExC_state);
11858         reginsert(pRExC_state, MINMOD, ret, depth+1);
11859         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11860     }
11861     else if (*RExC_parse == '+') {
11862         regnode *ender;
11863         nextchar(pRExC_state);
11864         ender = reg_node(pRExC_state, SUCCEED);
11865         REGTAIL(pRExC_state, ret, ender);
11866         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11867         ret->flags = 0;
11868         ender = reg_node(pRExC_state, TAIL);
11869         REGTAIL(pRExC_state, ret, ender);
11870     }
11871
11872     if (ISMULT2(RExC_parse)) {
11873         RExC_parse++;
11874         vFAIL("Nested quantifiers");
11875     }
11876
11877     return(ret);
11878 }
11879
11880 STATIC bool
11881 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11882                 regnode ** node_p,
11883                 UV * code_point_p,
11884                 int * cp_count,
11885                 I32 * flagp,
11886                 const bool strict,
11887                 const U32 depth
11888     )
11889 {
11890  /* This routine teases apart the various meanings of \N and returns
11891   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11892   * in the current context.
11893   *
11894   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11895   *
11896   * If <code_point_p> is not NULL, the context is expecting the result to be a
11897   * single code point.  If this \N instance turns out to a single code point,
11898   * the function returns TRUE and sets *code_point_p to that code point.
11899   *
11900   * If <node_p> is not NULL, the context is expecting the result to be one of
11901   * the things representable by a regnode.  If this \N instance turns out to be
11902   * one such, the function generates the regnode, returns TRUE and sets *node_p
11903   * to point to that regnode.
11904   *
11905   * If this instance of \N isn't legal in any context, this function will
11906   * generate a fatal error and not return.
11907   *
11908   * On input, RExC_parse should point to the first char following the \N at the
11909   * time of the call.  On successful return, RExC_parse will have been updated
11910   * to point to just after the sequence identified by this routine.  Also
11911   * *flagp has been updated as needed.
11912   *
11913   * When there is some problem with the current context and this \N instance,
11914   * the function returns FALSE, without advancing RExC_parse, nor setting
11915   * *node_p, nor *code_point_p, nor *flagp.
11916   *
11917   * If <cp_count> is not NULL, the caller wants to know the length (in code
11918   * points) that this \N sequence matches.  This is set even if the function
11919   * returns FALSE, as detailed below.
11920   *
11921   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11922   *
11923   * Probably the most common case is for the \N to specify a single code point.
11924   * *cp_count will be set to 1, and *code_point_p will be set to that code
11925   * point.
11926   *
11927   * Another possibility is for the input to be an empty \N{}, which for
11928   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11929   * will be set to a generated NOTHING node.
11930   *
11931   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11932   * set to 0. *node_p will be set to a generated REG_ANY node.
11933   *
11934   * The fourth possibility is that \N resolves to a sequence of more than one
11935   * code points.  *cp_count will be set to the number of code points in the
11936   * sequence. *node_p * will be set to a generated node returned by this
11937   * function calling S_reg().
11938   *
11939   * The final possibility is that it is premature to be calling this function;
11940   * that pass1 needs to be restarted.  This can happen when this changes from
11941   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
11942   * latter occurs only when the fourth possibility would otherwise be in
11943   * effect, and is because one of those code points requires the pattern to be
11944   * recompiled as UTF-8.  The function returns FALSE, and sets the
11945   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
11946   * happens, the caller needs to desist from continuing parsing, and return
11947   * this information to its caller.  This is not set for when there is only one
11948   * code point, as this can be called as part of an ANYOF node, and they can
11949   * store above-Latin1 code points without the pattern having to be in UTF-8.
11950   *
11951   * For non-single-quoted regexes, the tokenizer has resolved character and
11952   * sequence names inside \N{...} into their Unicode values, normalizing the
11953   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11954   * hex-represented code points in the sequence.  This is done there because
11955   * the names can vary based on what charnames pragma is in scope at the time,
11956   * so we need a way to take a snapshot of what they resolve to at the time of
11957   * the original parse. [perl #56444].
11958   *
11959   * That parsing is skipped for single-quoted regexes, so we may here get
11960   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11961   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11962   * is legal and handled here.  The code point is Unicode, and has to be
11963   * translated into the native character set for non-ASCII platforms.
11964   */
11965
11966     char * endbrace;    /* points to '}' following the name */
11967     char *endchar;      /* Points to '.' or '}' ending cur char in the input
11968                            stream */
11969     char* p = RExC_parse; /* Temporary */
11970
11971     GET_RE_DEBUG_FLAGS_DECL;
11972
11973     PERL_ARGS_ASSERT_GROK_BSLASH_N;
11974
11975     GET_RE_DEBUG_FLAGS;
11976
11977     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
11978     assert(! (node_p && cp_count));               /* At most 1 should be set */
11979
11980     if (cp_count) {     /* Initialize return for the most common case */
11981         *cp_count = 1;
11982     }
11983
11984     /* The [^\n] meaning of \N ignores spaces and comments under the /x
11985      * modifier.  The other meanings do not, so use a temporary until we find
11986      * out which we are being called with */
11987     skip_to_be_ignored_text(pRExC_state, &p,
11988                             FALSE /* Don't force to /x */ );
11989
11990     /* Disambiguate between \N meaning a named character versus \N meaning
11991      * [^\n].  The latter is assumed when the {...} following the \N is a legal
11992      * quantifier, or there is no '{' at all */
11993     if (*p != '{' || regcurly(p)) {
11994         RExC_parse = p;
11995         if (cp_count) {
11996             *cp_count = -1;
11997         }
11998
11999         if (! node_p) {
12000             return FALSE;
12001         }
12002
12003         *node_p = reg_node(pRExC_state, REG_ANY);
12004         *flagp |= HASWIDTH|SIMPLE;
12005         MARK_NAUGHTY(1);
12006         Set_Node_Length(*node_p, 1); /* MJD */
12007         return TRUE;
12008     }
12009
12010     /* Here, we have decided it should be a named character or sequence */
12011
12012     /* The test above made sure that the next real character is a '{', but
12013      * under the /x modifier, it could be separated by space (or a comment and
12014      * \n) and this is not allowed (for consistency with \x{...} and the
12015      * tokenizer handling of \N{NAME}). */
12016     if (*RExC_parse != '{') {
12017         vFAIL("Missing braces on \\N{}");
12018     }
12019
12020     RExC_parse++;       /* Skip past the '{' */
12021
12022     if (! (endbrace = strchr(RExC_parse, '}'))) { /* no trailing brace */
12023         vFAIL2("Missing right brace on \\%c{}", 'N');
12024     }
12025     else if(!(endbrace == RExC_parse            /* nothing between the {} */
12026               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
12027                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
12028                                                        error msg) */
12029     {
12030         RExC_parse = endbrace;  /* position msg's '<--HERE' */
12031         vFAIL("\\N{NAME} must be resolved by the lexer");
12032     }
12033
12034     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
12035                                         semantics */
12036
12037     if (endbrace == RExC_parse) {   /* empty: \N{} */
12038         if (strict) {
12039             RExC_parse++;   /* Position after the "}" */
12040             vFAIL("Zero length \\N{}");
12041         }
12042         if (cp_count) {
12043             *cp_count = 0;
12044         }
12045         nextchar(pRExC_state);
12046         if (! node_p) {
12047             return FALSE;
12048         }
12049
12050         *node_p = reg_node(pRExC_state,NOTHING);
12051         return TRUE;
12052     }
12053
12054     RExC_parse += 2;    /* Skip past the 'U+' */
12055
12056     /* Because toke.c has generated a special construct for us guaranteed not
12057      * to have NULs, we can use a str function */
12058     endchar = RExC_parse + strcspn(RExC_parse, ".}");
12059
12060     /* Code points are separated by dots.  If none, there is only one code
12061      * point, and is terminated by the brace */
12062
12063     if (endchar >= endbrace) {
12064         STRLEN length_of_hex;
12065         I32 grok_hex_flags;
12066
12067         /* Here, exactly one code point.  If that isn't what is wanted, fail */
12068         if (! code_point_p) {
12069             RExC_parse = p;
12070             return FALSE;
12071         }
12072
12073         /* Convert code point from hex */
12074         length_of_hex = (STRLEN)(endchar - RExC_parse);
12075         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
12076                            | PERL_SCAN_DISALLOW_PREFIX
12077
12078                              /* No errors in the first pass (See [perl
12079                               * #122671].)  We let the code below find the
12080                               * errors when there are multiple chars. */
12081                            | ((SIZE_ONLY)
12082                               ? PERL_SCAN_SILENT_ILLDIGIT
12083                               : 0);
12084
12085         /* This routine is the one place where both single- and double-quotish
12086          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
12087          * must be converted to native. */
12088         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
12089                                          &length_of_hex,
12090                                          &grok_hex_flags,
12091                                          NULL));
12092
12093         /* The tokenizer should have guaranteed validity, but it's possible to
12094          * bypass it by using single quoting, so check.  Don't do the check
12095          * here when there are multiple chars; we do it below anyway. */
12096         if (length_of_hex == 0
12097             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
12098         {
12099             RExC_parse += length_of_hex;        /* Includes all the valid */
12100             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
12101                             ? UTF8SKIP(RExC_parse)
12102                             : 1;
12103             /* Guard against malformed utf8 */
12104             if (RExC_parse >= endchar) {
12105                 RExC_parse = endchar;
12106             }
12107             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12108         }
12109
12110         RExC_parse = endbrace + 1;
12111         return TRUE;
12112     }
12113     else {  /* Is a multiple character sequence */
12114         SV * substitute_parse;
12115         STRLEN len;
12116         char *orig_end = RExC_end;
12117         char *save_start = RExC_start;
12118         I32 flags;
12119
12120         /* Count the code points, if desired, in the sequence */
12121         if (cp_count) {
12122             *cp_count = 0;
12123             while (RExC_parse < endbrace) {
12124                 /* Point to the beginning of the next character in the sequence. */
12125                 RExC_parse = endchar + 1;
12126                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
12127                 (*cp_count)++;
12128             }
12129         }
12130
12131         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12132          * But don't backup up the pointer if the caller want to know how many
12133          * code points there are (they can then handle things) */
12134         if (! node_p) {
12135             if (! cp_count) {
12136                 RExC_parse = p;
12137             }
12138             return FALSE;
12139         }
12140
12141         /* What is done here is to convert this to a sub-pattern of the form
12142          * \x{char1}\x{char2}...  and then call reg recursively to parse it
12143          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
12144          * while not having to worry about special handling that some code
12145          * points may have. */
12146
12147         substitute_parse = newSVpvs("?:");
12148
12149         while (RExC_parse < endbrace) {
12150
12151             /* Convert to notation the rest of the code understands */
12152             sv_catpv(substitute_parse, "\\x{");
12153             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
12154             sv_catpv(substitute_parse, "}");
12155
12156             /* Point to the beginning of the next character in the sequence. */
12157             RExC_parse = endchar + 1;
12158             endchar = RExC_parse + strcspn(RExC_parse, ".}");
12159
12160         }
12161         sv_catpv(substitute_parse, ")");
12162
12163         RExC_parse = RExC_start = RExC_adjusted_start = SvPV(substitute_parse,
12164                                                              len);
12165
12166         /* Don't allow empty number */
12167         if (len < (STRLEN) 8) {
12168             RExC_parse = endbrace;
12169             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12170         }
12171         RExC_end = RExC_parse + len;
12172
12173         /* The values are Unicode, and therefore not subject to recoding, but
12174          * have to be converted to native on a non-Unicode (meaning non-ASCII)
12175          * platform. */
12176 #ifdef EBCDIC
12177         RExC_recode_x_to_native = 1;
12178 #endif
12179
12180         if (node_p) {
12181             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
12182                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12183                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12184                     return FALSE;
12185                 }
12186                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#" UVxf,
12187                     (UV) flags);
12188             }
12189             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12190         }
12191
12192         /* Restore the saved values */
12193         RExC_start = RExC_adjusted_start = save_start;
12194         RExC_parse = endbrace;
12195         RExC_end = orig_end;
12196 #ifdef EBCDIC
12197         RExC_recode_x_to_native = 0;
12198 #endif
12199
12200         SvREFCNT_dec_NN(substitute_parse);
12201         nextchar(pRExC_state);
12202
12203         return TRUE;
12204     }
12205 }
12206
12207
12208 PERL_STATIC_INLINE U8
12209 S_compute_EXACTish(RExC_state_t *pRExC_state)
12210 {
12211     U8 op;
12212
12213     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12214
12215     if (! FOLD) {
12216         return (LOC)
12217                 ? EXACTL
12218                 : EXACT;
12219     }
12220
12221     op = get_regex_charset(RExC_flags);
12222     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12223         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12224                  been, so there is no hole */
12225     }
12226
12227     return op + EXACTF;
12228 }
12229
12230 PERL_STATIC_INLINE void
12231 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12232                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12233                          bool downgradable)
12234 {
12235     /* This knows the details about sizing an EXACTish node, setting flags for
12236      * it (by setting <*flagp>, and potentially populating it with a single
12237      * character.
12238      *
12239      * If <len> (the length in bytes) is non-zero, this function assumes that
12240      * the node has already been populated, and just does the sizing.  In this
12241      * case <code_point> should be the final code point that has already been
12242      * placed into the node.  This value will be ignored except that under some
12243      * circumstances <*flagp> is set based on it.
12244      *
12245      * If <len> is zero, the function assumes that the node is to contain only
12246      * the single character given by <code_point> and calculates what <len>
12247      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12248      * additionally will populate the node's STRING with <code_point> or its
12249      * fold if folding.
12250      *
12251      * In both cases <*flagp> is appropriately set
12252      *
12253      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12254      * 255, must be folded (the former only when the rules indicate it can
12255      * match 'ss')
12256      *
12257      * When it does the populating, it looks at the flag 'downgradable'.  If
12258      * true with a node that folds, it checks if the single code point
12259      * participates in a fold, and if not downgrades the node to an EXACT.
12260      * This helps the optimizer */
12261
12262     bool len_passed_in = cBOOL(len != 0);
12263     U8 character[UTF8_MAXBYTES_CASE+1];
12264
12265     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12266
12267     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12268      * sizing difference, and is extra work that is thrown away */
12269     if (downgradable && ! PASS2) {
12270         downgradable = FALSE;
12271     }
12272
12273     if (! len_passed_in) {
12274         if (UTF) {
12275             if (UVCHR_IS_INVARIANT(code_point)) {
12276                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12277                     *character = (U8) code_point;
12278                 }
12279                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12280                           ASCII, which isn't the same thing as INVARIANT on
12281                           EBCDIC, but it works there, as the extra invariants
12282                           fold to themselves) */
12283                     *character = toFOLD((U8) code_point);
12284
12285                     /* We can downgrade to an EXACT node if this character
12286                      * isn't a folding one.  Note that this assumes that
12287                      * nothing above Latin1 folds to some other invariant than
12288                      * one of these alphabetics; otherwise we would also have
12289                      * to check:
12290                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12291                      *      || ASCII_FOLD_RESTRICTED))
12292                      */
12293                     if (downgradable && PL_fold[code_point] == code_point) {
12294                         OP(node) = EXACT;
12295                     }
12296                 }
12297                 len = 1;
12298             }
12299             else if (FOLD && (! LOC
12300                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12301             {   /* Folding, and ok to do so now */
12302                 UV folded = _to_uni_fold_flags(
12303                                    code_point,
12304                                    character,
12305                                    &len,
12306                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12307                                                       ? FOLD_FLAGS_NOMIX_ASCII
12308                                                       : 0));
12309                 if (downgradable
12310                     && folded == code_point /* This quickly rules out many
12311                                                cases, avoiding the
12312                                                _invlist_contains_cp() overhead
12313                                                for those.  */
12314                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12315                 {
12316                     OP(node) = (LOC)
12317                                ? EXACTL
12318                                : EXACT;
12319                 }
12320             }
12321             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12322
12323                 /* Not folding this cp, and can output it directly */
12324                 *character = UTF8_TWO_BYTE_HI(code_point);
12325                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12326                 len = 2;
12327             }
12328             else {
12329                 uvchr_to_utf8( character, code_point);
12330                 len = UTF8SKIP(character);
12331             }
12332         } /* Else pattern isn't UTF8.  */
12333         else if (! FOLD) {
12334             *character = (U8) code_point;
12335             len = 1;
12336         } /* Else is folded non-UTF8 */
12337 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12338    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12339                                       || UNICODE_DOT_DOT_VERSION > 0)
12340         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12341 #else
12342         else if (1) {
12343 #endif
12344             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12345              * comments at join_exact()); */
12346             *character = (U8) code_point;
12347             len = 1;
12348
12349             /* Can turn into an EXACT node if we know the fold at compile time,
12350              * and it folds to itself and doesn't particpate in other folds */
12351             if (downgradable
12352                 && ! LOC
12353                 && PL_fold_latin1[code_point] == code_point
12354                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12355                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12356             {
12357                 OP(node) = EXACT;
12358             }
12359         } /* else is Sharp s.  May need to fold it */
12360         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12361             *character = 's';
12362             *(character + 1) = 's';
12363             len = 2;
12364         }
12365         else {
12366             *character = LATIN_SMALL_LETTER_SHARP_S;
12367             len = 1;
12368         }
12369     }
12370
12371     if (SIZE_ONLY) {
12372         RExC_size += STR_SZ(len);
12373     }
12374     else {
12375         RExC_emit += STR_SZ(len);
12376         STR_LEN(node) = len;
12377         if (! len_passed_in) {
12378             Copy((char *) character, STRING(node), len, char);
12379         }
12380     }
12381
12382     *flagp |= HASWIDTH;
12383
12384     /* A single character node is SIMPLE, except for the special-cased SHARP S
12385      * under /di. */
12386     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12387 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12388    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12389                                       || UNICODE_DOT_DOT_VERSION > 0)
12390         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12391             || ! FOLD || ! DEPENDS_SEMANTICS)
12392 #endif
12393     ) {
12394         *flagp |= SIMPLE;
12395     }
12396
12397     /* The OP may not be well defined in PASS1 */
12398     if (PASS2 && OP(node) == EXACTFL) {
12399         RExC_contains_locale = 1;
12400     }
12401 }
12402
12403
12404 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12405  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12406
12407 static I32
12408 S_backref_value(char *p)
12409 {
12410     const char* endptr;
12411     UV val;
12412     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12413         return (I32)val;
12414     return I32_MAX;
12415 }
12416
12417
12418 /*
12419  - regatom - the lowest level
12420
12421    Try to identify anything special at the start of the current parse position.
12422    If there is, then handle it as required. This may involve generating a
12423    single regop, such as for an assertion; or it may involve recursing, such as
12424    to handle a () structure.
12425
12426    If the string doesn't start with something special then we gobble up
12427    as much literal text as we can.  If we encounter a quantifier, we have to
12428    back off the final literal character, as that quantifier applies to just it
12429    and not to the whole string of literals.
12430
12431    Once we have been able to handle whatever type of thing started the
12432    sequence, we return.
12433
12434    Note: we have to be careful with escapes, as they can be both literal
12435    and special, and in the case of \10 and friends, context determines which.
12436
12437    A summary of the code structure is:
12438
12439    switch (first_byte) {
12440         cases for each special:
12441             handle this special;
12442             break;
12443         case '\\':
12444             switch (2nd byte) {
12445                 cases for each unambiguous special:
12446                     handle this special;
12447                     break;
12448                 cases for each ambigous special/literal:
12449                     disambiguate;
12450                     if (special)  handle here
12451                     else goto defchar;
12452                 default: // unambiguously literal:
12453                     goto defchar;
12454             }
12455         default:  // is a literal char
12456             // FALL THROUGH
12457         defchar:
12458             create EXACTish node for literal;
12459             while (more input and node isn't full) {
12460                 switch (input_byte) {
12461                    cases for each special;
12462                        make sure parse pointer is set so that the next call to
12463                            regatom will see this special first
12464                        goto loopdone; // EXACTish node terminated by prev. char
12465                    default:
12466                        append char to EXACTISH node;
12467                 }
12468                 get next input byte;
12469             }
12470         loopdone:
12471    }
12472    return the generated node;
12473
12474    Specifically there are two separate switches for handling
12475    escape sequences, with the one for handling literal escapes requiring
12476    a dummy entry for all of the special escapes that are actually handled
12477    by the other.
12478
12479    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12480    TRYAGAIN.
12481    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12482    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12483    Otherwise does not return NULL.
12484 */
12485
12486 STATIC regnode *
12487 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12488 {
12489     regnode *ret = NULL;
12490     I32 flags = 0;
12491     char *parse_start;
12492     U8 op;
12493     int invert = 0;
12494     U8 arg;
12495
12496     GET_RE_DEBUG_FLAGS_DECL;
12497
12498     *flagp = WORST;             /* Tentatively. */
12499
12500     DEBUG_PARSE("atom");
12501
12502     PERL_ARGS_ASSERT_REGATOM;
12503
12504   tryagain:
12505     parse_start = RExC_parse;
12506     assert(RExC_parse < RExC_end);
12507     switch ((U8)*RExC_parse) {
12508     case '^':
12509         RExC_seen_zerolen++;
12510         nextchar(pRExC_state);
12511         if (RExC_flags & RXf_PMf_MULTILINE)
12512             ret = reg_node(pRExC_state, MBOL);
12513         else
12514             ret = reg_node(pRExC_state, SBOL);
12515         Set_Node_Length(ret, 1); /* MJD */
12516         break;
12517     case '$':
12518         nextchar(pRExC_state);
12519         if (*RExC_parse)
12520             RExC_seen_zerolen++;
12521         if (RExC_flags & RXf_PMf_MULTILINE)
12522             ret = reg_node(pRExC_state, MEOL);
12523         else
12524             ret = reg_node(pRExC_state, SEOL);
12525         Set_Node_Length(ret, 1); /* MJD */
12526         break;
12527     case '.':
12528         nextchar(pRExC_state);
12529         if (RExC_flags & RXf_PMf_SINGLELINE)
12530             ret = reg_node(pRExC_state, SANY);
12531         else
12532             ret = reg_node(pRExC_state, REG_ANY);
12533         *flagp |= HASWIDTH|SIMPLE;
12534         MARK_NAUGHTY(1);
12535         Set_Node_Length(ret, 1); /* MJD */
12536         break;
12537     case '[':
12538     {
12539         char * const oregcomp_parse = ++RExC_parse;
12540         ret = regclass(pRExC_state, flagp,depth+1,
12541                        FALSE, /* means parse the whole char class */
12542                        TRUE, /* allow multi-char folds */
12543                        FALSE, /* don't silence non-portable warnings. */
12544                        (bool) RExC_strict,
12545                        TRUE, /* Allow an optimized regnode result */
12546                        NULL,
12547                        NULL);
12548         if (ret == NULL) {
12549             if (*flagp & (RESTART_PASS1|NEED_UTF8))
12550                 return NULL;
12551             FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12552                   (UV) *flagp);
12553         }
12554         if (*RExC_parse != ']') {
12555             RExC_parse = oregcomp_parse;
12556             vFAIL("Unmatched [");
12557         }
12558         nextchar(pRExC_state);
12559         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12560         break;
12561     }
12562     case '(':
12563         nextchar(pRExC_state);
12564         ret = reg(pRExC_state, 2, &flags,depth+1);
12565         if (ret == NULL) {
12566                 if (flags & TRYAGAIN) {
12567                     if (RExC_parse >= RExC_end) {
12568                          /* Make parent create an empty node if needed. */
12569                         *flagp |= TRYAGAIN;
12570                         return(NULL);
12571                     }
12572                     goto tryagain;
12573                 }
12574                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12575                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12576                     return NULL;
12577                 }
12578                 FAIL2("panic: reg returned NULL to regatom, flags=%#" UVxf,
12579                                                                  (UV) flags);
12580         }
12581         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12582         break;
12583     case '|':
12584     case ')':
12585         if (flags & TRYAGAIN) {
12586             *flagp |= TRYAGAIN;
12587             return NULL;
12588         }
12589         vFAIL("Internal urp");
12590                                 /* Supposed to be caught earlier. */
12591         break;
12592     case '?':
12593     case '+':
12594     case '*':
12595         RExC_parse++;
12596         vFAIL("Quantifier follows nothing");
12597         break;
12598     case '\\':
12599         /* Special Escapes
12600
12601            This switch handles escape sequences that resolve to some kind
12602            of special regop and not to literal text. Escape sequnces that
12603            resolve to literal text are handled below in the switch marked
12604            "Literal Escapes".
12605
12606            Every entry in this switch *must* have a corresponding entry
12607            in the literal escape switch. However, the opposite is not
12608            required, as the default for this switch is to jump to the
12609            literal text handling code.
12610         */
12611         RExC_parse++;
12612         switch ((U8)*RExC_parse) {
12613         /* Special Escapes */
12614         case 'A':
12615             RExC_seen_zerolen++;
12616             ret = reg_node(pRExC_state, SBOL);
12617             /* SBOL is shared with /^/ so we set the flags so we can tell
12618              * /\A/ from /^/ in split. We check ret because first pass we
12619              * have no regop struct to set the flags on. */
12620             if (PASS2)
12621                 ret->flags = 1;
12622             *flagp |= SIMPLE;
12623             goto finish_meta_pat;
12624         case 'G':
12625             ret = reg_node(pRExC_state, GPOS);
12626             RExC_seen |= REG_GPOS_SEEN;
12627             *flagp |= SIMPLE;
12628             goto finish_meta_pat;
12629         case 'K':
12630             RExC_seen_zerolen++;
12631             ret = reg_node(pRExC_state, KEEPS);
12632             *flagp |= SIMPLE;
12633             /* XXX:dmq : disabling in-place substitution seems to
12634              * be necessary here to avoid cases of memory corruption, as
12635              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
12636              */
12637             RExC_seen |= REG_LOOKBEHIND_SEEN;
12638             goto finish_meta_pat;
12639         case 'Z':
12640             ret = reg_node(pRExC_state, SEOL);
12641             *flagp |= SIMPLE;
12642             RExC_seen_zerolen++;                /* Do not optimize RE away */
12643             goto finish_meta_pat;
12644         case 'z':
12645             ret = reg_node(pRExC_state, EOS);
12646             *flagp |= SIMPLE;
12647             RExC_seen_zerolen++;                /* Do not optimize RE away */
12648             goto finish_meta_pat;
12649         case 'C':
12650             vFAIL("\\C no longer supported");
12651         case 'X':
12652             ret = reg_node(pRExC_state, CLUMP);
12653             *flagp |= HASWIDTH;
12654             goto finish_meta_pat;
12655
12656         case 'W':
12657             invert = 1;
12658             /* FALLTHROUGH */
12659         case 'w':
12660             arg = ANYOF_WORDCHAR;
12661             goto join_posix;
12662
12663         case 'B':
12664             invert = 1;
12665             /* FALLTHROUGH */
12666         case 'b':
12667           {
12668             regex_charset charset = get_regex_charset(RExC_flags);
12669
12670             RExC_seen_zerolen++;
12671             RExC_seen |= REG_LOOKBEHIND_SEEN;
12672             op = BOUND + charset;
12673
12674             if (op == BOUNDL) {
12675                 RExC_contains_locale = 1;
12676             }
12677
12678             ret = reg_node(pRExC_state, op);
12679             *flagp |= SIMPLE;
12680             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
12681                 FLAGS(ret) = TRADITIONAL_BOUND;
12682                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
12683                     OP(ret) = BOUNDA;
12684                 }
12685             }
12686             else {
12687                 STRLEN length;
12688                 char name = *RExC_parse;
12689                 char * endbrace;
12690                 RExC_parse += 2;
12691                 endbrace = strchr(RExC_parse, '}');
12692
12693                 if (! endbrace) {
12694                     vFAIL2("Missing right brace on \\%c{}", name);
12695                 }
12696                 /* XXX Need to decide whether to take spaces or not.  Should be
12697                  * consistent with \p{}, but that currently is SPACE, which
12698                  * means vertical too, which seems wrong
12699                  * while (isBLANK(*RExC_parse)) {
12700                     RExC_parse++;
12701                 }*/
12702                 if (endbrace == RExC_parse) {
12703                     RExC_parse++;  /* After the '}' */
12704                     vFAIL2("Empty \\%c{}", name);
12705                 }
12706                 length = endbrace - RExC_parse;
12707                 /*while (isBLANK(*(RExC_parse + length - 1))) {
12708                     length--;
12709                 }*/
12710                 switch (*RExC_parse) {
12711                     case 'g':
12712                         if (length != 1
12713                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
12714                         {
12715                             goto bad_bound_type;
12716                         }
12717                         FLAGS(ret) = GCB_BOUND;
12718                         break;
12719                     case 'l':
12720                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12721                             goto bad_bound_type;
12722                         }
12723                         FLAGS(ret) = LB_BOUND;
12724                         break;
12725                     case 's':
12726                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12727                             goto bad_bound_type;
12728                         }
12729                         FLAGS(ret) = SB_BOUND;
12730                         break;
12731                     case 'w':
12732                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12733                             goto bad_bound_type;
12734                         }
12735                         FLAGS(ret) = WB_BOUND;
12736                         break;
12737                     default:
12738                       bad_bound_type:
12739                         RExC_parse = endbrace;
12740                         vFAIL2utf8f(
12741                             "'%" UTF8f "' is an unknown bound type",
12742                             UTF8fARG(UTF, length, endbrace - length));
12743                         NOT_REACHED; /*NOTREACHED*/
12744                 }
12745                 RExC_parse = endbrace;
12746                 REQUIRE_UNI_RULES(flagp, NULL);
12747
12748                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
12749                     OP(ret) = BOUNDU;
12750                     length += 4;
12751
12752                     /* Don't have to worry about UTF-8, in this message because
12753                      * to get here the contents of the \b must be ASCII */
12754                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
12755                               "Using /u for '%.*s' instead of /%s",
12756                               (unsigned) length,
12757                               endbrace - length + 1,
12758                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
12759                               ? ASCII_RESTRICT_PAT_MODS
12760                               : ASCII_MORE_RESTRICT_PAT_MODS);
12761                 }
12762             }
12763
12764             if (PASS2 && invert) {
12765                 OP(ret) += NBOUND - BOUND;
12766             }
12767             goto finish_meta_pat;
12768           }
12769
12770         case 'D':
12771             invert = 1;
12772             /* FALLTHROUGH */
12773         case 'd':
12774             arg = ANYOF_DIGIT;
12775             if (! DEPENDS_SEMANTICS) {
12776                 goto join_posix;
12777             }
12778
12779             /* \d doesn't have any matches in the upper Latin1 range, hence /d
12780              * is equivalent to /u.  Changing to /u saves some branches at
12781              * runtime */
12782             op = POSIXU;
12783             goto join_posix_op_known;
12784
12785         case 'R':
12786             ret = reg_node(pRExC_state, LNBREAK);
12787             *flagp |= HASWIDTH|SIMPLE;
12788             goto finish_meta_pat;
12789
12790         case 'H':
12791             invert = 1;
12792             /* FALLTHROUGH */
12793         case 'h':
12794             arg = ANYOF_BLANK;
12795             op = POSIXU;
12796             goto join_posix_op_known;
12797
12798         case 'V':
12799             invert = 1;
12800             /* FALLTHROUGH */
12801         case 'v':
12802             arg = ANYOF_VERTWS;
12803             op = POSIXU;
12804             goto join_posix_op_known;
12805
12806         case 'S':
12807             invert = 1;
12808             /* FALLTHROUGH */
12809         case 's':
12810             arg = ANYOF_SPACE;
12811
12812           join_posix:
12813
12814             op = POSIXD + get_regex_charset(RExC_flags);
12815             if (op > POSIXA) {  /* /aa is same as /a */
12816                 op = POSIXA;
12817             }
12818             else if (op == POSIXL) {
12819                 RExC_contains_locale = 1;
12820             }
12821
12822           join_posix_op_known:
12823
12824             if (invert) {
12825                 op += NPOSIXD - POSIXD;
12826             }
12827
12828             ret = reg_node(pRExC_state, op);
12829             if (! SIZE_ONLY) {
12830                 FLAGS(ret) = namedclass_to_classnum(arg);
12831             }
12832
12833             *flagp |= HASWIDTH|SIMPLE;
12834             /* FALLTHROUGH */
12835
12836           finish_meta_pat:
12837             nextchar(pRExC_state);
12838             Set_Node_Length(ret, 2); /* MJD */
12839             break;
12840         case 'p':
12841         case 'P':
12842             RExC_parse--;
12843
12844             ret = regclass(pRExC_state, flagp,depth+1,
12845                            TRUE, /* means just parse this element */
12846                            FALSE, /* don't allow multi-char folds */
12847                            FALSE, /* don't silence non-portable warnings.  It
12848                                      would be a bug if these returned
12849                                      non-portables */
12850                            (bool) RExC_strict,
12851                            TRUE, /* Allow an optimized regnode result */
12852                            NULL,
12853                            NULL);
12854             if (*flagp & RESTART_PASS1)
12855                 return NULL;
12856             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
12857              * multi-char folds are allowed.  */
12858             if (!ret)
12859                 FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12860                       (UV) *flagp);
12861
12862             RExC_parse--;
12863
12864             Set_Node_Offset(ret, parse_start);
12865             Set_Node_Cur_Length(ret, parse_start - 2);
12866             nextchar(pRExC_state);
12867             break;
12868         case 'N':
12869             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12870              * \N{...} evaluates to a sequence of more than one code points).
12871              * The function call below returns a regnode, which is our result.
12872              * The parameters cause it to fail if the \N{} evaluates to a
12873              * single code point; we handle those like any other literal.  The
12874              * reason that the multicharacter case is handled here and not as
12875              * part of the EXACtish code is because of quantifiers.  In
12876              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12877              * this way makes that Just Happen. dmq.
12878              * join_exact() will join this up with adjacent EXACTish nodes
12879              * later on, if appropriate. */
12880             ++RExC_parse;
12881             if (grok_bslash_N(pRExC_state,
12882                               &ret,     /* Want a regnode returned */
12883                               NULL,     /* Fail if evaluates to a single code
12884                                            point */
12885                               NULL,     /* Don't need a count of how many code
12886                                            points */
12887                               flagp,
12888                               RExC_strict,
12889                               depth)
12890             ) {
12891                 break;
12892             }
12893
12894             if (*flagp & RESTART_PASS1)
12895                 return NULL;
12896
12897             /* Here, evaluates to a single code point.  Go get that */
12898             RExC_parse = parse_start;
12899             goto defchar;
12900
12901         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12902       parse_named_seq:
12903         {
12904             char ch;
12905             if (   RExC_parse >= RExC_end - 1
12906                 || ((   ch = RExC_parse[1]) != '<'
12907                                       && ch != '\''
12908                                       && ch != '{'))
12909             {
12910                 RExC_parse++;
12911                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12912                 vFAIL2("Sequence %.2s... not terminated",parse_start);
12913             } else {
12914                 RExC_parse += 2;
12915                 ret = handle_named_backref(pRExC_state,
12916                                            flagp,
12917                                            parse_start,
12918                                            (ch == '<')
12919                                            ? '>'
12920                                            : (ch == '{')
12921                                              ? '}'
12922                                              : '\'');
12923             }
12924             break;
12925         }
12926         case 'g':
12927         case '1': case '2': case '3': case '4':
12928         case '5': case '6': case '7': case '8': case '9':
12929             {
12930                 I32 num;
12931                 bool hasbrace = 0;
12932
12933                 if (*RExC_parse == 'g') {
12934                     bool isrel = 0;
12935
12936                     RExC_parse++;
12937                     if (*RExC_parse == '{') {
12938                         RExC_parse++;
12939                         hasbrace = 1;
12940                     }
12941                     if (*RExC_parse == '-') {
12942                         RExC_parse++;
12943                         isrel = 1;
12944                     }
12945                     if (hasbrace && !isDIGIT(*RExC_parse)) {
12946                         if (isrel) RExC_parse--;
12947                         RExC_parse -= 2;
12948                         goto parse_named_seq;
12949                     }
12950
12951                     if (RExC_parse >= RExC_end) {
12952                         goto unterminated_g;
12953                     }
12954                     num = S_backref_value(RExC_parse);
12955                     if (num == 0)
12956                         vFAIL("Reference to invalid group 0");
12957                     else if (num == I32_MAX) {
12958                          if (isDIGIT(*RExC_parse))
12959                             vFAIL("Reference to nonexistent group");
12960                         else
12961                           unterminated_g:
12962                             vFAIL("Unterminated \\g... pattern");
12963                     }
12964
12965                     if (isrel) {
12966                         num = RExC_npar - num;
12967                         if (num < 1)
12968                             vFAIL("Reference to nonexistent or unclosed group");
12969                     }
12970                 }
12971                 else {
12972                     num = S_backref_value(RExC_parse);
12973                     /* bare \NNN might be backref or octal - if it is larger
12974                      * than or equal RExC_npar then it is assumed to be an
12975                      * octal escape. Note RExC_npar is +1 from the actual
12976                      * number of parens. */
12977                     /* Note we do NOT check if num == I32_MAX here, as that is
12978                      * handled by the RExC_npar check */
12979
12980                     if (
12981                         /* any numeric escape < 10 is always a backref */
12982                         num > 9
12983                         /* any numeric escape < RExC_npar is a backref */
12984                         && num >= RExC_npar
12985                         /* cannot be an octal escape if it starts with 8 */
12986                         && *RExC_parse != '8'
12987                         /* cannot be an octal escape it it starts with 9 */
12988                         && *RExC_parse != '9'
12989                     )
12990                     {
12991                         /* Probably not a backref, instead likely to be an
12992                          * octal character escape, e.g. \35 or \777.
12993                          * The above logic should make it obvious why using
12994                          * octal escapes in patterns is problematic. - Yves */
12995                         RExC_parse = parse_start;
12996                         goto defchar;
12997                     }
12998                 }
12999
13000                 /* At this point RExC_parse points at a numeric escape like
13001                  * \12 or \88 or something similar, which we should NOT treat
13002                  * as an octal escape. It may or may not be a valid backref
13003                  * escape. For instance \88888888 is unlikely to be a valid
13004                  * backref. */
13005                 while (isDIGIT(*RExC_parse))
13006                     RExC_parse++;
13007                 if (hasbrace) {
13008                     if (*RExC_parse != '}')
13009                         vFAIL("Unterminated \\g{...} pattern");
13010                     RExC_parse++;
13011                 }
13012                 if (!SIZE_ONLY) {
13013                     if (num > (I32)RExC_rx->nparens)
13014                         vFAIL("Reference to nonexistent group");
13015                 }
13016                 RExC_sawback = 1;
13017                 ret = reganode(pRExC_state,
13018                                ((! FOLD)
13019                                  ? REF
13020                                  : (ASCII_FOLD_RESTRICTED)
13021                                    ? REFFA
13022                                    : (AT_LEAST_UNI_SEMANTICS)
13023                                      ? REFFU
13024                                      : (LOC)
13025                                        ? REFFL
13026                                        : REFF),
13027                                 num);
13028                 *flagp |= HASWIDTH;
13029
13030                 /* override incorrect value set in reganode MJD */
13031                 Set_Node_Offset(ret, parse_start);
13032                 Set_Node_Cur_Length(ret, parse_start-1);
13033                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13034                                         FALSE /* Don't force to /x */ );
13035             }
13036             break;
13037         case '\0':
13038             if (RExC_parse >= RExC_end)
13039                 FAIL("Trailing \\");
13040             /* FALLTHROUGH */
13041         default:
13042             /* Do not generate "unrecognized" warnings here, we fall
13043                back into the quick-grab loop below */
13044             RExC_parse = parse_start;
13045             goto defchar;
13046         } /* end of switch on a \foo sequence */
13047         break;
13048
13049     case '#':
13050
13051         /* '#' comments should have been spaced over before this function was
13052          * called */
13053         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13054         /*
13055         if (RExC_flags & RXf_PMf_EXTENDED) {
13056             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13057             if (RExC_parse < RExC_end)
13058                 goto tryagain;
13059         }
13060         */
13061
13062         /* FALLTHROUGH */
13063
13064     default:
13065           defchar: {
13066
13067             /* Here, we have determined that the next thing is probably a
13068              * literal character.  RExC_parse points to the first byte of its
13069              * definition.  (It still may be an escape sequence that evaluates
13070              * to a single character) */
13071
13072             STRLEN len = 0;
13073             UV ender = 0;
13074             char *p;
13075             char *s;
13076 #define MAX_NODE_STRING_SIZE 127
13077             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
13078             char *s0;
13079             U8 upper_parse = MAX_NODE_STRING_SIZE;
13080             U8 node_type = compute_EXACTish(pRExC_state);
13081             bool next_is_quantifier;
13082             char * oldp = NULL;
13083
13084             /* We can convert EXACTF nodes to EXACTFU if they contain only
13085              * characters that match identically regardless of the target
13086              * string's UTF8ness.  The reason to do this is that EXACTF is not
13087              * trie-able, EXACTFU is.
13088              *
13089              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13090              * contain only above-Latin1 characters (hence must be in UTF8),
13091              * which don't participate in folds with Latin1-range characters,
13092              * as the latter's folds aren't known until runtime.  (We don't
13093              * need to figure this out until pass 2) */
13094             bool maybe_exactfu = PASS2
13095                                && (node_type == EXACTF || node_type == EXACTFL);
13096
13097             /* If a folding node contains only code points that don't
13098              * participate in folds, it can be changed into an EXACT node,
13099              * which allows the optimizer more things to look for */
13100             bool maybe_exact;
13101
13102             ret = reg_node(pRExC_state, node_type);
13103
13104             /* In pass1, folded, we use a temporary buffer instead of the
13105              * actual node, as the node doesn't exist yet */
13106             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
13107
13108             s0 = s;
13109
13110           reparse:
13111
13112             /* We look for the EXACTFish to EXACT node optimizaton only if
13113              * folding.  (And we don't need to figure this out until pass 2).
13114              * XXX It might actually make sense to split the node into portions
13115              * that are exact and ones that aren't, so that we could later use
13116              * the exact ones to find the longest fixed and floating strings.
13117              * One would want to join them back into a larger node.  One could
13118              * use a pseudo regnode like 'EXACT_ORIG_FOLD' */
13119             maybe_exact = FOLD && PASS2;
13120
13121             /* XXX The node can hold up to 255 bytes, yet this only goes to
13122              * 127.  I (khw) do not know why.  Keeping it somewhat less than
13123              * 255 allows us to not have to worry about overflow due to
13124              * converting to utf8 and fold expansion, but that value is
13125              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
13126              * split up by this limit into a single one using the real max of
13127              * 255.  Even at 127, this breaks under rare circumstances.  If
13128              * folding, we do not want to split a node at a character that is a
13129              * non-final in a multi-char fold, as an input string could just
13130              * happen to want to match across the node boundary.  The join
13131              * would solve that problem if the join actually happens.  But a
13132              * series of more than two nodes in a row each of 127 would cause
13133              * the first join to succeed to get to 254, but then there wouldn't
13134              * be room for the next one, which could at be one of those split
13135              * multi-char folds.  I don't know of any fool-proof solution.  One
13136              * could back off to end with only a code point that isn't such a
13137              * non-final, but it is possible for there not to be any in the
13138              * entire node. */
13139
13140             assert(   ! UTF     /* Is at the beginning of a character */
13141                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13142                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13143
13144             /* Here, we have a literal character.  Find the maximal string of
13145              * them in the input that we can fit into a single EXACTish node.
13146              * We quit at the first non-literal or when the node gets full */
13147             for (p = RExC_parse;
13148                  len < upper_parse && p < RExC_end;
13149                  len++)
13150             {
13151                 oldp = p;
13152
13153                 /* White space has already been ignored */
13154                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13155                        || ! is_PATWS_safe((p), RExC_end, UTF));
13156
13157                 switch ((U8)*p) {
13158                 case '^':
13159                 case '$':
13160                 case '.':
13161                 case '[':
13162                 case '(':
13163                 case ')':
13164                 case '|':
13165                     goto loopdone;
13166                 case '\\':
13167                     /* Literal Escapes Switch
13168
13169                        This switch is meant to handle escape sequences that
13170                        resolve to a literal character.
13171
13172                        Every escape sequence that represents something
13173                        else, like an assertion or a char class, is handled
13174                        in the switch marked 'Special Escapes' above in this
13175                        routine, but also has an entry here as anything that
13176                        isn't explicitly mentioned here will be treated as
13177                        an unescaped equivalent literal.
13178                     */
13179
13180                     switch ((U8)*++p) {
13181                     /* These are all the special escapes. */
13182                     case 'A':             /* Start assertion */
13183                     case 'b': case 'B':   /* Word-boundary assertion*/
13184                     case 'C':             /* Single char !DANGEROUS! */
13185                     case 'd': case 'D':   /* digit class */
13186                     case 'g': case 'G':   /* generic-backref, pos assertion */
13187                     case 'h': case 'H':   /* HORIZWS */
13188                     case 'k': case 'K':   /* named backref, keep marker */
13189                     case 'p': case 'P':   /* Unicode property */
13190                               case 'R':   /* LNBREAK */
13191                     case 's': case 'S':   /* space class */
13192                     case 'v': case 'V':   /* VERTWS */
13193                     case 'w': case 'W':   /* word class */
13194                     case 'X':             /* eXtended Unicode "combining
13195                                              character sequence" */
13196                     case 'z': case 'Z':   /* End of line/string assertion */
13197                         --p;
13198                         goto loopdone;
13199
13200                     /* Anything after here is an escape that resolves to a
13201                        literal. (Except digits, which may or may not)
13202                      */
13203                     case 'n':
13204                         ender = '\n';
13205                         p++;
13206                         break;
13207                     case 'N': /* Handle a single-code point named character. */
13208                         RExC_parse = p + 1;
13209                         if (! grok_bslash_N(pRExC_state,
13210                                             NULL,   /* Fail if evaluates to
13211                                                        anything other than a
13212                                                        single code point */
13213                                             &ender, /* The returned single code
13214                                                        point */
13215                                             NULL,   /* Don't need a count of
13216                                                        how many code points */
13217                                             flagp,
13218                                             RExC_strict,
13219                                             depth)
13220                         ) {
13221                             if (*flagp & NEED_UTF8)
13222                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13223                             if (*flagp & RESTART_PASS1)
13224                                 return NULL;
13225
13226                             /* Here, it wasn't a single code point.  Go close
13227                              * up this EXACTish node.  The switch() prior to
13228                              * this switch handles the other cases */
13229                             RExC_parse = p = oldp;
13230                             goto loopdone;
13231                         }
13232                         p = RExC_parse;
13233                         if (ender > 0xff) {
13234                             REQUIRE_UTF8(flagp);
13235                         }
13236                         break;
13237                     case 'r':
13238                         ender = '\r';
13239                         p++;
13240                         break;
13241                     case 't':
13242                         ender = '\t';
13243                         p++;
13244                         break;
13245                     case 'f':
13246                         ender = '\f';
13247                         p++;
13248                         break;
13249                     case 'e':
13250                         ender = ESC_NATIVE;
13251                         p++;
13252                         break;
13253                     case 'a':
13254                         ender = '\a';
13255                         p++;
13256                         break;
13257                     case 'o':
13258                         {
13259                             UV result;
13260                             const char* error_msg;
13261
13262                             bool valid = grok_bslash_o(&p,
13263                                                        &result,
13264                                                        &error_msg,
13265                                                        PASS2, /* out warnings */
13266                                                        (bool) RExC_strict,
13267                                                        TRUE, /* Output warnings
13268                                                                 for non-
13269                                                                 portables */
13270                                                        UTF);
13271                             if (! valid) {
13272                                 RExC_parse = p; /* going to die anyway; point
13273                                                    to exact spot of failure */
13274                                 vFAIL(error_msg);
13275                             }
13276                             ender = result;
13277                             if (ender > 0xff) {
13278                                 REQUIRE_UTF8(flagp);
13279                             }
13280                             break;
13281                         }
13282                     case 'x':
13283                         {
13284                             UV result = UV_MAX; /* initialize to erroneous
13285                                                    value */
13286                             const char* error_msg;
13287
13288                             bool valid = grok_bslash_x(&p,
13289                                                        &result,
13290                                                        &error_msg,
13291                                                        PASS2, /* out warnings */
13292                                                        (bool) RExC_strict,
13293                                                        TRUE, /* Silence warnings
13294                                                                 for non-
13295                                                                 portables */
13296                                                        UTF);
13297                             if (! valid) {
13298                                 RExC_parse = p; /* going to die anyway; point
13299                                                    to exact spot of failure */
13300                                 vFAIL(error_msg);
13301                             }
13302                             ender = result;
13303
13304                             if (ender < 0x100) {
13305 #ifdef EBCDIC
13306                                 if (RExC_recode_x_to_native) {
13307                                     ender = LATIN1_TO_NATIVE(ender);
13308                                 }
13309 #endif
13310                             }
13311                             else {
13312                                 REQUIRE_UTF8(flagp);
13313                             }
13314                             break;
13315                         }
13316                     case 'c':
13317                         p++;
13318                         ender = grok_bslash_c(*p++, PASS2);
13319                         break;
13320                     case '8': case '9': /* must be a backreference */
13321                         --p;
13322                         /* we have an escape like \8 which cannot be an octal escape
13323                          * so we exit the loop, and let the outer loop handle this
13324                          * escape which may or may not be a legitimate backref. */
13325                         goto loopdone;
13326                     case '1': case '2': case '3':case '4':
13327                     case '5': case '6': case '7':
13328                         /* When we parse backslash escapes there is ambiguity
13329                          * between backreferences and octal escapes. Any escape
13330                          * from \1 - \9 is a backreference, any multi-digit
13331                          * escape which does not start with 0 and which when
13332                          * evaluated as decimal could refer to an already
13333                          * parsed capture buffer is a back reference. Anything
13334                          * else is octal.
13335                          *
13336                          * Note this implies that \118 could be interpreted as
13337                          * 118 OR as "\11" . "8" depending on whether there
13338                          * were 118 capture buffers defined already in the
13339                          * pattern.  */
13340
13341                         /* NOTE, RExC_npar is 1 more than the actual number of
13342                          * parens we have seen so far, hence the < RExC_npar below. */
13343
13344                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13345                         {  /* Not to be treated as an octal constant, go
13346                                    find backref */
13347                             --p;
13348                             goto loopdone;
13349                         }
13350                         /* FALLTHROUGH */
13351                     case '0':
13352                         {
13353                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13354                             STRLEN numlen = 3;
13355                             ender = grok_oct(p, &numlen, &flags, NULL);
13356                             if (ender > 0xff) {
13357                                 REQUIRE_UTF8(flagp);
13358                             }
13359                             p += numlen;
13360                             if (PASS2   /* like \08, \178 */
13361                                 && numlen < 3
13362                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13363                             {
13364                                 reg_warn_non_literal_string(
13365                                          p + 1,
13366                                          form_short_octal_warning(p, numlen));
13367                             }
13368                         }
13369                         break;
13370                     case '\0':
13371                         if (p >= RExC_end)
13372                             FAIL("Trailing \\");
13373                         /* FALLTHROUGH */
13374                     default:
13375                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13376                             /* Include any left brace following the alpha to emphasize
13377                              * that it could be part of an escape at some point
13378                              * in the future */
13379                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13380                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13381                         }
13382                         goto normal_default;
13383                     } /* End of switch on '\' */
13384                     break;
13385                 case '{':
13386                     /* Currently we don't care if the lbrace is at the start
13387                      * of a construct.  This catches it in the middle of a
13388                      * literal string, or when it's the first thing after
13389                      * something like "\b" */
13390                     if (len || (p > RExC_start && isALPHA_A(*(p -1)))) {
13391                         RExC_parse = p + 1;
13392                         vFAIL("Unescaped left brace in regex is illegal here");
13393                     }
13394                     goto normal_default;
13395                 case '}':
13396                 case ']':
13397                     if (PASS2 && p > RExC_parse && RExC_strict) {
13398                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
13399                     }
13400                     /*FALLTHROUGH*/
13401                 default:    /* A literal character */
13402                   normal_default:
13403                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13404                         STRLEN numlen;
13405                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13406                                                &numlen, UTF8_ALLOW_DEFAULT);
13407                         p += numlen;
13408                     }
13409                     else
13410                         ender = (U8) *p++;
13411                     break;
13412                 } /* End of switch on the literal */
13413
13414                 /* Here, have looked at the literal character and <ender>
13415                  * contains its ordinal, <p> points to the character after it.
13416                  * We need to check if the next non-ignored thing is a
13417                  * quantifier.  Move <p> to after anything that should be
13418                  * ignored, which, as a side effect, positions <p> for the next
13419                  * loop iteration */
13420                 skip_to_be_ignored_text(pRExC_state, &p,
13421                                         FALSE /* Don't force to /x */ );
13422
13423                 /* If the next thing is a quantifier, it applies to this
13424                  * character only, which means that this character has to be in
13425                  * its own node and can't just be appended to the string in an
13426                  * existing node, so if there are already other characters in
13427                  * the node, close the node with just them, and set up to do
13428                  * this character again next time through, when it will be the
13429                  * only thing in its new node */
13430
13431                 if ((next_is_quantifier = (   LIKELY(p < RExC_end)
13432                                            && UNLIKELY(ISMULT2(p))))
13433                     && LIKELY(len))
13434                 {
13435                     p = oldp;
13436                     goto loopdone;
13437                 }
13438
13439                 /* Ready to add 'ender' to the node */
13440
13441                 if (! FOLD) {  /* The simple case, just append the literal */
13442
13443                     /* In the sizing pass, we need only the size of the
13444                      * character we are appending, hence we can delay getting
13445                      * its representation until PASS2. */
13446                     if (SIZE_ONLY) {
13447                         if (UTF) {
13448                             const STRLEN unilen = UVCHR_SKIP(ender);
13449                             s += unilen;
13450
13451                             /* We have to subtract 1 just below (and again in
13452                              * the corresponding PASS2 code) because the loop
13453                              * increments <len> each time, as all but this path
13454                              * (and one other) through it add a single byte to
13455                              * the EXACTish node.  But these paths would change
13456                              * len to be the correct final value, so cancel out
13457                              * the increment that follows */
13458                             len += unilen - 1;
13459                         }
13460                         else {
13461                             s++;
13462                         }
13463                     } else { /* PASS2 */
13464                       not_fold_common:
13465                         if (UTF) {
13466                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13467                             len += (char *) new_s - s - 1;
13468                             s = (char *) new_s;
13469                         }
13470                         else {
13471                             *(s++) = (char) ender;
13472                         }
13473                     }
13474                 }
13475                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13476
13477                     /* Here are folding under /l, and the code point is
13478                      * problematic.  First, we know we can't simplify things */
13479                     maybe_exact = FALSE;
13480                     maybe_exactfu = FALSE;
13481
13482                     /* A problematic code point in this context means that its
13483                      * fold isn't known until runtime, so we can't fold it now.
13484                      * (The non-problematic code points are the above-Latin1
13485                      * ones that fold to also all above-Latin1.  Their folds
13486                      * don't vary no matter what the locale is.) But here we
13487                      * have characters whose fold depends on the locale.
13488                      * Unlike the non-folding case above, we have to keep track
13489                      * of these in the sizing pass, so that we can make sure we
13490                      * don't split too-long nodes in the middle of a potential
13491                      * multi-char fold.  And unlike the regular fold case
13492                      * handled in the else clauses below, we don't actually
13493                      * fold and don't have special cases to consider.  What we
13494                      * do for both passes is the PASS2 code for non-folding */
13495                     goto not_fold_common;
13496                 }
13497                 else /* A regular FOLD code point */
13498                     if (! (   UTF
13499 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13500    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13501                                       || UNICODE_DOT_DOT_VERSION > 0)
13502                             /* See comments for join_exact() as to why we fold
13503                              * this non-UTF at compile time */
13504                             || (   node_type == EXACTFU
13505                                 && ender == LATIN_SMALL_LETTER_SHARP_S)
13506 #endif
13507                 )) {
13508                     /* Here, are folding and are not UTF-8 encoded; therefore
13509                      * the character must be in the range 0-255, and is not /l
13510                      * (Not /l because we already handled these under /l in
13511                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13512                     if (IS_IN_SOME_FOLD_L1(ender)) {
13513                         maybe_exact = FALSE;
13514
13515                         /* See if the character's fold differs between /d and
13516                          * /u.  This includes the multi-char fold SHARP S to
13517                          * 'ss' */
13518                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13519                             RExC_seen_unfolded_sharp_s = 1;
13520                             maybe_exactfu = FALSE;
13521                         }
13522                         else if (maybe_exactfu
13523                             && (PL_fold[ender] != PL_fold_latin1[ender]
13524 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13525    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13526                                       || UNICODE_DOT_DOT_VERSION > 0)
13527                                 || (   len > 0
13528                                     && isALPHA_FOLD_EQ(ender, 's')
13529                                     && isALPHA_FOLD_EQ(*(s-1), 's'))
13530 #endif
13531                         )) {
13532                             maybe_exactfu = FALSE;
13533                         }
13534                     }
13535
13536                     /* Even when folding, we store just the input character, as
13537                      * we have an array that finds its fold quickly */
13538                     *(s++) = (char) ender;
13539                 }
13540                 else {  /* FOLD, and UTF (or sharp s) */
13541                     /* Unlike the non-fold case, we do actually have to
13542                      * calculate the results here in pass 1.  This is for two
13543                      * reasons, the folded length may be longer than the
13544                      * unfolded, and we have to calculate how many EXACTish
13545                      * nodes it will take; and we may run out of room in a node
13546                      * in the middle of a potential multi-char fold, and have
13547                      * to back off accordingly.  */
13548
13549                     UV folded;
13550                     if (isASCII_uni(ender)) {
13551                         folded = toFOLD(ender);
13552                         *(s)++ = (U8) folded;
13553                     }
13554                     else {
13555                         STRLEN foldlen;
13556
13557                         folded = _to_uni_fold_flags(
13558                                      ender,
13559                                      (U8 *) s,
13560                                      &foldlen,
13561                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
13562                                                         ? FOLD_FLAGS_NOMIX_ASCII
13563                                                         : 0));
13564                         s += foldlen;
13565
13566                         /* The loop increments <len> each time, as all but this
13567                          * path (and one other) through it add a single byte to
13568                          * the EXACTish node.  But this one has changed len to
13569                          * be the correct final value, so subtract one to
13570                          * cancel out the increment that follows */
13571                         len += foldlen - 1;
13572                     }
13573                     /* If this node only contains non-folding code points so
13574                      * far, see if this new one is also non-folding */
13575                     if (maybe_exact) {
13576                         if (folded != ender) {
13577                             maybe_exact = FALSE;
13578                         }
13579                         else {
13580                             /* Here the fold is the original; we have to check
13581                              * further to see if anything folds to it */
13582                             if (_invlist_contains_cp(PL_utf8_foldable,
13583                                                         ender))
13584                             {
13585                                 maybe_exact = FALSE;
13586                             }
13587                         }
13588                     }
13589                     ender = folded;
13590                 }
13591
13592                 if (next_is_quantifier) {
13593
13594                     /* Here, the next input is a quantifier, and to get here,
13595                      * the current character is the only one in the node.
13596                      * Also, here <len> doesn't include the final byte for this
13597                      * character */
13598                     len++;
13599                     goto loopdone;
13600                 }
13601
13602             } /* End of loop through literal characters */
13603
13604             /* Here we have either exhausted the input or ran out of room in
13605              * the node.  (If we encountered a character that can't be in the
13606              * node, transfer is made directly to <loopdone>, and so we
13607              * wouldn't have fallen off the end of the loop.)  In the latter
13608              * case, we artificially have to split the node into two, because
13609              * we just don't have enough space to hold everything.  This
13610              * creates a problem if the final character participates in a
13611              * multi-character fold in the non-final position, as a match that
13612              * should have occurred won't, due to the way nodes are matched,
13613              * and our artificial boundary.  So back off until we find a non-
13614              * problematic character -- one that isn't at the beginning or
13615              * middle of such a fold.  (Either it doesn't participate in any
13616              * folds, or appears only in the final position of all the folds it
13617              * does participate in.)  A better solution with far fewer false
13618              * positives, and that would fill the nodes more completely, would
13619              * be to actually have available all the multi-character folds to
13620              * test against, and to back-off only far enough to be sure that
13621              * this node isn't ending with a partial one.  <upper_parse> is set
13622              * further below (if we need to reparse the node) to include just
13623              * up through that final non-problematic character that this code
13624              * identifies, so when it is set to less than the full node, we can
13625              * skip the rest of this */
13626             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
13627
13628                 const STRLEN full_len = len;
13629
13630                 assert(len >= MAX_NODE_STRING_SIZE);
13631
13632                 /* Here, <s> points to the final byte of the final character.
13633                  * Look backwards through the string until find a non-
13634                  * problematic character */
13635
13636                 if (! UTF) {
13637
13638                     /* This has no multi-char folds to non-UTF characters */
13639                     if (ASCII_FOLD_RESTRICTED) {
13640                         goto loopdone;
13641                     }
13642
13643                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
13644                     len = s - s0 + 1;
13645                 }
13646                 else {
13647                     if (!  PL_NonL1NonFinalFold) {
13648                         PL_NonL1NonFinalFold = _new_invlist_C_array(
13649                                         NonL1_Perl_Non_Final_Folds_invlist);
13650                     }
13651
13652                     /* Point to the first byte of the final character */
13653                     s = (char *) utf8_hop((U8 *) s, -1);
13654
13655                     while (s >= s0) {   /* Search backwards until find
13656                                            non-problematic char */
13657                         if (UTF8_IS_INVARIANT(*s)) {
13658
13659                             /* There are no ascii characters that participate
13660                              * in multi-char folds under /aa.  In EBCDIC, the
13661                              * non-ascii invariants are all control characters,
13662                              * so don't ever participate in any folds. */
13663                             if (ASCII_FOLD_RESTRICTED
13664                                 || ! IS_NON_FINAL_FOLD(*s))
13665                             {
13666                                 break;
13667                             }
13668                         }
13669                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
13670                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
13671                                                                   *s, *(s+1))))
13672                             {
13673                                 break;
13674                             }
13675                         }
13676                         else if (! _invlist_contains_cp(
13677                                         PL_NonL1NonFinalFold,
13678                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
13679                         {
13680                             break;
13681                         }
13682
13683                         /* Here, the current character is problematic in that
13684                          * it does occur in the non-final position of some
13685                          * fold, so try the character before it, but have to
13686                          * special case the very first byte in the string, so
13687                          * we don't read outside the string */
13688                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
13689                     } /* End of loop backwards through the string */
13690
13691                     /* If there were only problematic characters in the string,
13692                      * <s> will point to before s0, in which case the length
13693                      * should be 0, otherwise include the length of the
13694                      * non-problematic character just found */
13695                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
13696                 }
13697
13698                 /* Here, have found the final character, if any, that is
13699                  * non-problematic as far as ending the node without splitting
13700                  * it across a potential multi-char fold.  <len> contains the
13701                  * number of bytes in the node up-to and including that
13702                  * character, or is 0 if there is no such character, meaning
13703                  * the whole node contains only problematic characters.  In
13704                  * this case, give up and just take the node as-is.  We can't
13705                  * do any better */
13706                 if (len == 0) {
13707                     len = full_len;
13708
13709                     /* If the node ends in an 's' we make sure it stays EXACTF,
13710                      * as if it turns into an EXACTFU, it could later get
13711                      * joined with another 's' that would then wrongly match
13712                      * the sharp s */
13713                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
13714                     {
13715                         maybe_exactfu = FALSE;
13716                     }
13717                 } else {
13718
13719                     /* Here, the node does contain some characters that aren't
13720                      * problematic.  If one such is the final character in the
13721                      * node, we are done */
13722                     if (len == full_len) {
13723                         goto loopdone;
13724                     }
13725                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
13726
13727                         /* If the final character is problematic, but the
13728                          * penultimate is not, back-off that last character to
13729                          * later start a new node with it */
13730                         p = oldp;
13731                         goto loopdone;
13732                     }
13733
13734                     /* Here, the final non-problematic character is earlier
13735                      * in the input than the penultimate character.  What we do
13736                      * is reparse from the beginning, going up only as far as
13737                      * this final ok one, thus guaranteeing that the node ends
13738                      * in an acceptable character.  The reason we reparse is
13739                      * that we know how far in the character is, but we don't
13740                      * know how to correlate its position with the input parse.
13741                      * An alternate implementation would be to build that
13742                      * correlation as we go along during the original parse,
13743                      * but that would entail extra work for every node, whereas
13744                      * this code gets executed only when the string is too
13745                      * large for the node, and the final two characters are
13746                      * problematic, an infrequent occurrence.  Yet another
13747                      * possible strategy would be to save the tail of the
13748                      * string, and the next time regatom is called, initialize
13749                      * with that.  The problem with this is that unless you
13750                      * back off one more character, you won't be guaranteed
13751                      * regatom will get called again, unless regbranch,
13752                      * regpiece ... are also changed.  If you do back off that
13753                      * extra character, so that there is input guaranteed to
13754                      * force calling regatom, you can't handle the case where
13755                      * just the first character in the node is acceptable.  I
13756                      * (khw) decided to try this method which doesn't have that
13757                      * pitfall; if performance issues are found, we can do a
13758                      * combination of the current approach plus that one */
13759                     upper_parse = len;
13760                     len = 0;
13761                     s = s0;
13762                     goto reparse;
13763                 }
13764             }   /* End of verifying node ends with an appropriate char */
13765
13766           loopdone:   /* Jumped to when encounters something that shouldn't be
13767                          in the node */
13768
13769             /* I (khw) don't know if you can get here with zero length, but the
13770              * old code handled this situation by creating a zero-length EXACT
13771              * node.  Might as well be NOTHING instead */
13772             if (len == 0) {
13773                 OP(ret) = NOTHING;
13774             }
13775             else {
13776                 if (FOLD) {
13777                     /* If 'maybe_exact' is still set here, means there are no
13778                      * code points in the node that participate in folds;
13779                      * similarly for 'maybe_exactfu' and code points that match
13780                      * differently depending on UTF8ness of the target string
13781                      * (for /u), or depending on locale for /l */
13782                     if (maybe_exact) {
13783                         OP(ret) = (LOC)
13784                                   ? EXACTL
13785                                   : EXACT;
13786                     }
13787                     else if (maybe_exactfu) {
13788                         OP(ret) = (LOC)
13789                                   ? EXACTFLU8
13790                                   : EXACTFU;
13791                     }
13792                 }
13793                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
13794                                            FALSE /* Don't look to see if could
13795                                                     be turned into an EXACT
13796                                                     node, as we have already
13797                                                     computed that */
13798                                           );
13799             }
13800
13801             RExC_parse = p - 1;
13802             Set_Node_Cur_Length(ret, parse_start);
13803             RExC_parse = p;
13804             {
13805                 /* len is STRLEN which is unsigned, need to copy to signed */
13806                 IV iv = len;
13807                 if (iv < 0)
13808                     vFAIL("Internal disaster");
13809             }
13810
13811         } /* End of label 'defchar:' */
13812         break;
13813     } /* End of giant switch on input character */
13814
13815     /* Position parse to next real character */
13816     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13817                                             FALSE /* Don't force to /x */ );
13818     if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
13819         ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here (and will be fatal in Perl 5.30), passed through");
13820     }
13821
13822     return(ret);
13823 }
13824
13825
13826 STATIC void
13827 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
13828 {
13829     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13830      * sets up the bitmap and any flags, removing those code points from the
13831      * inversion list, setting it to NULL should it become completely empty */
13832
13833     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13834     assert(PL_regkind[OP(node)] == ANYOF);
13835
13836     ANYOF_BITMAP_ZERO(node);
13837     if (*invlist_ptr) {
13838
13839         /* This gets set if we actually need to modify things */
13840         bool change_invlist = FALSE;
13841
13842         UV start, end;
13843
13844         /* Start looking through *invlist_ptr */
13845         invlist_iterinit(*invlist_ptr);
13846         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13847             UV high;
13848             int i;
13849
13850             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13851                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13852             }
13853
13854             /* Quit if are above what we should change */
13855             if (start >= NUM_ANYOF_CODE_POINTS) {
13856                 break;
13857             }
13858
13859             change_invlist = TRUE;
13860
13861             /* Set all the bits in the range, up to the max that we are doing */
13862             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13863                    ? end
13864                    : NUM_ANYOF_CODE_POINTS - 1;
13865             for (i = start; i <= (int) high; i++) {
13866                 if (! ANYOF_BITMAP_TEST(node, i)) {
13867                     ANYOF_BITMAP_SET(node, i);
13868                 }
13869             }
13870         }
13871         invlist_iterfinish(*invlist_ptr);
13872
13873         /* Done with loop; remove any code points that are in the bitmap from
13874          * *invlist_ptr; similarly for code points above the bitmap if we have
13875          * a flag to match all of them anyways */
13876         if (change_invlist) {
13877             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13878         }
13879         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13880             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13881         }
13882
13883         /* If have completely emptied it, remove it completely */
13884         if (_invlist_len(*invlist_ptr) == 0) {
13885             SvREFCNT_dec_NN(*invlist_ptr);
13886             *invlist_ptr = NULL;
13887         }
13888     }
13889 }
13890
13891 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
13892    Character classes ([:foo:]) can also be negated ([:^foo:]).
13893    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
13894    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
13895    but trigger failures because they are currently unimplemented. */
13896
13897 #define POSIXCC_DONE(c)   ((c) == ':')
13898 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
13899 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
13900 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
13901
13902 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
13903 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
13904 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
13905
13906 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
13907
13908 /* 'posix_warnings' and 'warn_text' are names of variables in the following
13909  * routine. q.v. */
13910 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
13911         if (posix_warnings) {                                               \
13912             if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
13913             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                          \
13914                                              WARNING_PREFIX                 \
13915                                              text                           \
13916                                              REPORT_LOCATION,               \
13917                                              REPORT_LOCATION_ARGS(p)));     \
13918         }                                                                   \
13919     } STMT_END
13920
13921 STATIC int
13922 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
13923
13924     const char * const s,      /* Where the putative posix class begins.
13925                                   Normally, this is one past the '['.  This
13926                                   parameter exists so it can be somewhere
13927                                   besides RExC_parse. */
13928     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
13929                                   NULL */
13930     AV ** posix_warnings,      /* Where to place any generated warnings, or
13931                                   NULL */
13932     const bool check_only      /* Don't die if error */
13933 )
13934 {
13935     /* This parses what the caller thinks may be one of the three POSIX
13936      * constructs:
13937      *  1) a character class, like [:blank:]
13938      *  2) a collating symbol, like [. .]
13939      *  3) an equivalence class, like [= =]
13940      * In the latter two cases, it croaks if it finds a syntactically legal
13941      * one, as these are not handled by Perl.
13942      *
13943      * The main purpose is to look for a POSIX character class.  It returns:
13944      *  a) the class number
13945      *      if it is a completely syntactically and semantically legal class.
13946      *      'updated_parse_ptr', if not NULL, is set to point to just after the
13947      *      closing ']' of the class
13948      *  b) OOB_NAMEDCLASS
13949      *      if it appears that one of the three POSIX constructs was meant, but
13950      *      its specification was somehow defective.  'updated_parse_ptr', if
13951      *      not NULL, is set to point to the character just after the end
13952      *      character of the class.  See below for handling of warnings.
13953      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
13954      *      if it  doesn't appear that a POSIX construct was intended.
13955      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
13956      *      raised.
13957      *
13958      * In b) there may be errors or warnings generated.  If 'check_only' is
13959      * TRUE, then any errors are discarded.  Warnings are returned to the
13960      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
13961      * instead it is NULL, warnings are suppressed.  This is done in all
13962      * passes.  The reason for this is that the rest of the parsing is heavily
13963      * dependent on whether this routine found a valid posix class or not.  If
13964      * it did, the closing ']' is absorbed as part of the class.  If no class,
13965      * or an invalid one is found, any ']' will be considered the terminator of
13966      * the outer bracketed character class, leading to very different results.
13967      * In particular, a '(?[ ])' construct will likely have a syntax error if
13968      * the class is parsed other than intended, and this will happen in pass1,
13969      * before the warnings would normally be output.  This mechanism allows the
13970      * caller to output those warnings in pass1 just before dieing, giving a
13971      * much better clue as to what is wrong.
13972      *
13973      * The reason for this function, and its complexity is that a bracketed
13974      * character class can contain just about anything.  But it's easy to
13975      * mistype the very specific posix class syntax but yielding a valid
13976      * regular bracketed class, so it silently gets compiled into something
13977      * quite unintended.
13978      *
13979      * The solution adopted here maintains backward compatibility except that
13980      * it adds a warning if it looks like a posix class was intended but
13981      * improperly specified.  The warning is not raised unless what is input
13982      * very closely resembles one of the 14 legal posix classes.  To do this,
13983      * it uses fuzzy parsing.  It calculates how many single-character edits it
13984      * would take to transform what was input into a legal posix class.  Only
13985      * if that number is quite small does it think that the intention was a
13986      * posix class.  Obviously these are heuristics, and there will be cases
13987      * where it errs on one side or another, and they can be tweaked as
13988      * experience informs.
13989      *
13990      * The syntax for a legal posix class is:
13991      *
13992      * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
13993      *
13994      * What this routine considers syntactically to be an intended posix class
13995      * is this (the comments indicate some restrictions that the pattern
13996      * doesn't show):
13997      *
13998      *  qr/(?x: \[?                         # The left bracket, possibly
13999      *                                      # omitted
14000      *          \h*                         # possibly followed by blanks
14001      *          (?: \^ \h* )?               # possibly a misplaced caret
14002      *          [:;]?                       # The opening class character,
14003      *                                      # possibly omitted.  A typo
14004      *                                      # semi-colon can also be used.
14005      *          \h*
14006      *          \^?                         # possibly a correctly placed
14007      *                                      # caret, but not if there was also
14008      *                                      # a misplaced one
14009      *          \h*
14010      *          .{3,15}                     # The class name.  If there are
14011      *                                      # deviations from the legal syntax,
14012      *                                      # its edit distance must be close
14013      *                                      # to a real class name in order
14014      *                                      # for it to be considered to be
14015      *                                      # an intended posix class.
14016      *          \h*
14017      *          [:punct:]?                  # The closing class character,
14018      *                                      # possibly omitted.  If not a colon
14019      *                                      # nor semi colon, the class name
14020      *                                      # must be even closer to a valid
14021      *                                      # one
14022      *          \h*
14023      *          \]?                         # The right bracket, possibly
14024      *                                      # omitted.
14025      *     )/
14026      *
14027      * In the above, \h must be ASCII-only.
14028      *
14029      * These are heuristics, and can be tweaked as field experience dictates.
14030      * There will be cases when someone didn't intend to specify a posix class
14031      * that this warns as being so.  The goal is to minimize these, while
14032      * maximizing the catching of things intended to be a posix class that
14033      * aren't parsed as such.
14034      */
14035
14036     const char* p             = s;
14037     const char * const e      = RExC_end;
14038     unsigned complement       = 0;      /* If to complement the class */
14039     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
14040     bool has_opening_bracket  = FALSE;
14041     bool has_opening_colon    = FALSE;
14042     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
14043                                                    valid class */
14044     const char * possible_end = NULL;   /* used for a 2nd parse pass */
14045     const char* name_start;             /* ptr to class name first char */
14046
14047     /* If the number of single-character typos the input name is away from a
14048      * legal name is no more than this number, it is considered to have meant
14049      * the legal name */
14050     int max_distance          = 2;
14051
14052     /* to store the name.  The size determines the maximum length before we
14053      * decide that no posix class was intended.  Should be at least
14054      * sizeof("alphanumeric") */
14055     UV input_text[15];
14056
14057     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
14058
14059     if (posix_warnings && RExC_warn_text)
14060         av_clear(RExC_warn_text);
14061
14062     if (p >= e) {
14063         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14064     }
14065
14066     if (*(p - 1) != '[') {
14067         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
14068         found_problem = TRUE;
14069     }
14070     else {
14071         has_opening_bracket = TRUE;
14072     }
14073
14074     /* They could be confused and think you can put spaces between the
14075      * components */
14076     if (isBLANK(*p)) {
14077         found_problem = TRUE;
14078
14079         do {
14080             p++;
14081         } while (p < e && isBLANK(*p));
14082
14083         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14084     }
14085
14086     /* For [. .] and [= =].  These are quite different internally from [: :],
14087      * so they are handled separately.  */
14088     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
14089                                             and 1 for at least one char in it
14090                                           */
14091     {
14092         const char open_char  = *p;
14093         const char * temp_ptr = p + 1;
14094
14095         /* These two constructs are not handled by perl, and if we find a
14096          * syntactically valid one, we croak.  khw, who wrote this code, finds
14097          * this explanation of them very unclear:
14098          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
14099          * And searching the rest of the internet wasn't very helpful either.
14100          * It looks like just about any byte can be in these constructs,
14101          * depending on the locale.  But unless the pattern is being compiled
14102          * under /l, which is very rare, Perl runs under the C or POSIX locale.
14103          * In that case, it looks like [= =] isn't allowed at all, and that
14104          * [. .] could be any single code point, but for longer strings the
14105          * constituent characters would have to be the ASCII alphabetics plus
14106          * the minus-hyphen.  Any sensible locale definition would limit itself
14107          * to these.  And any portable one definitely should.  Trying to parse
14108          * the general case is a nightmare (see [perl #127604]).  So, this code
14109          * looks only for interiors of these constructs that match:
14110          *      qr/.|[-\w]{2,}/
14111          * Using \w relaxes the apparent rules a little, without adding much
14112          * danger of mistaking something else for one of these constructs.
14113          *
14114          * [. .] in some implementations described on the internet is usable to
14115          * escape a character that otherwise is special in bracketed character
14116          * classes.  For example [.].] means a literal right bracket instead of
14117          * the ending of the class
14118          *
14119          * [= =] can legitimately contain a [. .] construct, but we don't
14120          * handle this case, as that [. .] construct will later get parsed
14121          * itself and croak then.  And [= =] is checked for even when not under
14122          * /l, as Perl has long done so.
14123          *
14124          * The code below relies on there being a trailing NUL, so it doesn't
14125          * have to keep checking if the parse ptr < e.
14126          */
14127         if (temp_ptr[1] == open_char) {
14128             temp_ptr++;
14129         }
14130         else while (    temp_ptr < e
14131                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
14132         {
14133             temp_ptr++;
14134         }
14135
14136         if (*temp_ptr == open_char) {
14137             temp_ptr++;
14138             if (*temp_ptr == ']') {
14139                 temp_ptr++;
14140                 if (! found_problem && ! check_only) {
14141                     RExC_parse = (char *) temp_ptr;
14142                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
14143                             "extensions", open_char, open_char);
14144                 }
14145
14146                 /* Here, the syntax wasn't completely valid, or else the call
14147                  * is to check-only */
14148                 if (updated_parse_ptr) {
14149                     *updated_parse_ptr = (char *) temp_ptr;
14150                 }
14151
14152                 return OOB_NAMEDCLASS;
14153             }
14154         }
14155
14156         /* If we find something that started out to look like one of these
14157          * constructs, but isn't, we continue below so that it can be checked
14158          * for being a class name with a typo of '.' or '=' instead of a colon.
14159          * */
14160     }
14161
14162     /* Here, we think there is a possibility that a [: :] class was meant, and
14163      * we have the first real character.  It could be they think the '^' comes
14164      * first */
14165     if (*p == '^') {
14166         found_problem = TRUE;
14167         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
14168         complement = 1;
14169         p++;
14170
14171         if (isBLANK(*p)) {
14172             found_problem = TRUE;
14173
14174             do {
14175                 p++;
14176             } while (p < e && isBLANK(*p));
14177
14178             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14179         }
14180     }
14181
14182     /* But the first character should be a colon, which they could have easily
14183      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
14184      * distinguish from a colon, so treat that as a colon).  */
14185     if (*p == ':') {
14186         p++;
14187         has_opening_colon = TRUE;
14188     }
14189     else if (*p == ';') {
14190         found_problem = TRUE;
14191         p++;
14192         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14193         has_opening_colon = TRUE;
14194     }
14195     else {
14196         found_problem = TRUE;
14197         ADD_POSIX_WARNING(p, "there must be a starting ':'");
14198
14199         /* Consider an initial punctuation (not one of the recognized ones) to
14200          * be a left terminator */
14201         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
14202             p++;
14203         }
14204     }
14205
14206     /* They may think that you can put spaces between the components */
14207     if (isBLANK(*p)) {
14208         found_problem = TRUE;
14209
14210         do {
14211             p++;
14212         } while (p < e && isBLANK(*p));
14213
14214         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14215     }
14216
14217     if (*p == '^') {
14218
14219         /* We consider something like [^:^alnum:]] to not have been intended to
14220          * be a posix class, but XXX maybe we should */
14221         if (complement) {
14222             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14223         }
14224
14225         complement = 1;
14226         p++;
14227     }
14228
14229     /* Again, they may think that you can put spaces between the components */
14230     if (isBLANK(*p)) {
14231         found_problem = TRUE;
14232
14233         do {
14234             p++;
14235         } while (p < e && isBLANK(*p));
14236
14237         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14238     }
14239
14240     if (*p == ']') {
14241
14242         /* XXX This ']' may be a typo, and something else was meant.  But
14243          * treating it as such creates enough complications, that that
14244          * possibility isn't currently considered here.  So we assume that the
14245          * ']' is what is intended, and if we've already found an initial '[',
14246          * this leaves this construct looking like [:] or [:^], which almost
14247          * certainly weren't intended to be posix classes */
14248         if (has_opening_bracket) {
14249             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14250         }
14251
14252         /* But this function can be called when we parse the colon for
14253          * something like qr/[alpha:]]/, so we back up to look for the
14254          * beginning */
14255         p--;
14256
14257         if (*p == ';') {
14258             found_problem = TRUE;
14259             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14260         }
14261         else if (*p != ':') {
14262
14263             /* XXX We are currently very restrictive here, so this code doesn't
14264              * consider the possibility that, say, /[alpha.]]/ was intended to
14265              * be a posix class. */
14266             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14267         }
14268
14269         /* Here we have something like 'foo:]'.  There was no initial colon,
14270          * and we back up over 'foo.  XXX Unlike the going forward case, we
14271          * don't handle typos of non-word chars in the middle */
14272         has_opening_colon = FALSE;
14273         p--;
14274
14275         while (p > RExC_start && isWORDCHAR(*p)) {
14276             p--;
14277         }
14278         p++;
14279
14280         /* Here, we have positioned ourselves to where we think the first
14281          * character in the potential class is */
14282     }
14283
14284     /* Now the interior really starts.  There are certain key characters that
14285      * can end the interior, or these could just be typos.  To catch both
14286      * cases, we may have to do two passes.  In the first pass, we keep on
14287      * going unless we come to a sequence that matches
14288      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14289      * This means it takes a sequence to end the pass, so two typos in a row if
14290      * that wasn't what was intended.  If the class is perfectly formed, just
14291      * this one pass is needed.  We also stop if there are too many characters
14292      * being accumulated, but this number is deliberately set higher than any
14293      * real class.  It is set high enough so that someone who thinks that
14294      * 'alphanumeric' is a correct name would get warned that it wasn't.
14295      * While doing the pass, we keep track of where the key characters were in
14296      * it.  If we don't find an end to the class, and one of the key characters
14297      * was found, we redo the pass, but stop when we get to that character.
14298      * Thus the key character was considered a typo in the first pass, but a
14299      * terminator in the second.  If two key characters are found, we stop at
14300      * the second one in the first pass.  Again this can miss two typos, but
14301      * catches a single one
14302      *
14303      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14304      * point to the first key character.  For the second pass, it starts as -1.
14305      * */
14306
14307     name_start = p;
14308   parse_name:
14309     {
14310         bool has_blank               = FALSE;
14311         bool has_upper               = FALSE;
14312         bool has_terminating_colon   = FALSE;
14313         bool has_terminating_bracket = FALSE;
14314         bool has_semi_colon          = FALSE;
14315         unsigned int name_len        = 0;
14316         int punct_count              = 0;
14317
14318         while (p < e) {
14319
14320             /* Squeeze out blanks when looking up the class name below */
14321             if (isBLANK(*p) ) {
14322                 has_blank = TRUE;
14323                 found_problem = TRUE;
14324                 p++;
14325                 continue;
14326             }
14327
14328             /* The name will end with a punctuation */
14329             if (isPUNCT(*p)) {
14330                 const char * peek = p + 1;
14331
14332                 /* Treat any non-']' punctuation followed by a ']' (possibly
14333                  * with intervening blanks) as trying to terminate the class.
14334                  * ']]' is very likely to mean a class was intended (but
14335                  * missing the colon), but the warning message that gets
14336                  * generated shows the error position better if we exit the
14337                  * loop at the bottom (eventually), so skip it here. */
14338                 if (*p != ']') {
14339                     if (peek < e && isBLANK(*peek)) {
14340                         has_blank = TRUE;
14341                         found_problem = TRUE;
14342                         do {
14343                             peek++;
14344                         } while (peek < e && isBLANK(*peek));
14345                     }
14346
14347                     if (peek < e && *peek == ']') {
14348                         has_terminating_bracket = TRUE;
14349                         if (*p == ':') {
14350                             has_terminating_colon = TRUE;
14351                         }
14352                         else if (*p == ';') {
14353                             has_semi_colon = TRUE;
14354                             has_terminating_colon = TRUE;
14355                         }
14356                         else {
14357                             found_problem = TRUE;
14358                         }
14359                         p = peek + 1;
14360                         goto try_posix;
14361                     }
14362                 }
14363
14364                 /* Here we have punctuation we thought didn't end the class.
14365                  * Keep track of the position of the key characters that are
14366                  * more likely to have been class-enders */
14367                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14368
14369                     /* Allow just one such possible class-ender not actually
14370                      * ending the class. */
14371                     if (possible_end) {
14372                         break;
14373                     }
14374                     possible_end = p;
14375                 }
14376
14377                 /* If we have too many punctuation characters, no use in
14378                  * keeping going */
14379                 if (++punct_count > max_distance) {
14380                     break;
14381                 }
14382
14383                 /* Treat the punctuation as a typo. */
14384                 input_text[name_len++] = *p;
14385                 p++;
14386             }
14387             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14388                 input_text[name_len++] = toLOWER(*p);
14389                 has_upper = TRUE;
14390                 found_problem = TRUE;
14391                 p++;
14392             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14393                 input_text[name_len++] = *p;
14394                 p++;
14395             }
14396             else {
14397                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14398                 p+= UTF8SKIP(p);
14399             }
14400
14401             /* The declaration of 'input_text' is how long we allow a potential
14402              * class name to be, before saying they didn't mean a class name at
14403              * all */
14404             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14405                 break;
14406             }
14407         }
14408
14409         /* We get to here when the possible class name hasn't been properly
14410          * terminated before:
14411          *   1) we ran off the end of the pattern; or
14412          *   2) found two characters, each of which might have been intended to
14413          *      be the name's terminator
14414          *   3) found so many punctuation characters in the purported name,
14415          *      that the edit distance to a valid one is exceeded
14416          *   4) we decided it was more characters than anyone could have
14417          *      intended to be one. */
14418
14419         found_problem = TRUE;
14420
14421         /* In the final two cases, we know that looking up what we've
14422          * accumulated won't lead to a match, even a fuzzy one. */
14423         if (   name_len >= C_ARRAY_LENGTH(input_text)
14424             || punct_count > max_distance)
14425         {
14426             /* If there was an intermediate key character that could have been
14427              * an intended end, redo the parse, but stop there */
14428             if (possible_end && possible_end != (char *) -1) {
14429                 possible_end = (char *) -1; /* Special signal value to say
14430                                                we've done a first pass */
14431                 p = name_start;
14432                 goto parse_name;
14433             }
14434
14435             /* Otherwise, it can't have meant to have been a class */
14436             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14437         }
14438
14439         /* If we ran off the end, and the final character was a punctuation
14440          * one, back up one, to look at that final one just below.  Later, we
14441          * will restore the parse pointer if appropriate */
14442         if (name_len && p == e && isPUNCT(*(p-1))) {
14443             p--;
14444             name_len--;
14445         }
14446
14447         if (p < e && isPUNCT(*p)) {
14448             if (*p == ']') {
14449                 has_terminating_bracket = TRUE;
14450
14451                 /* If this is a 2nd ']', and the first one is just below this
14452                  * one, consider that to be the real terminator.  This gives a
14453                  * uniform and better positioning for the warning message  */
14454                 if (   possible_end
14455                     && possible_end != (char *) -1
14456                     && *possible_end == ']'
14457                     && name_len && input_text[name_len - 1] == ']')
14458                 {
14459                     name_len--;
14460                     p = possible_end;
14461
14462                     /* And this is actually equivalent to having done the 2nd
14463                      * pass now, so set it to not try again */
14464                     possible_end = (char *) -1;
14465                 }
14466             }
14467             else {
14468                 if (*p == ':') {
14469                     has_terminating_colon = TRUE;
14470                 }
14471                 else if (*p == ';') {
14472                     has_semi_colon = TRUE;
14473                     has_terminating_colon = TRUE;
14474                 }
14475                 p++;
14476             }
14477         }
14478
14479     try_posix:
14480
14481         /* Here, we have a class name to look up.  We can short circuit the
14482          * stuff below for short names that can't possibly be meant to be a
14483          * class name.  (We can do this on the first pass, as any second pass
14484          * will yield an even shorter name) */
14485         if (name_len < 3) {
14486             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14487         }
14488
14489         /* Find which class it is.  Initially switch on the length of the name.
14490          * */
14491         switch (name_len) {
14492             case 4:
14493                 if (memEQ(name_start, "word", 4)) {
14494                     /* this is not POSIX, this is the Perl \w */
14495                     class_number = ANYOF_WORDCHAR;
14496                 }
14497                 break;
14498             case 5:
14499                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14500                  *                        graph lower print punct space upper
14501                  * Offset 4 gives the best switch position.  */
14502                 switch (name_start[4]) {
14503                     case 'a':
14504                         if (memEQ(name_start, "alph", 4)) /* alpha */
14505                             class_number = ANYOF_ALPHA;
14506                         break;
14507                     case 'e':
14508                         if (memEQ(name_start, "spac", 4)) /* space */
14509                             class_number = ANYOF_SPACE;
14510                         break;
14511                     case 'h':
14512                         if (memEQ(name_start, "grap", 4)) /* graph */
14513                             class_number = ANYOF_GRAPH;
14514                         break;
14515                     case 'i':
14516                         if (memEQ(name_start, "asci", 4)) /* ascii */
14517                             class_number = ANYOF_ASCII;
14518                         break;
14519                     case 'k':
14520                         if (memEQ(name_start, "blan", 4)) /* blank */
14521                             class_number = ANYOF_BLANK;
14522                         break;
14523                     case 'l':
14524                         if (memEQ(name_start, "cntr", 4)) /* cntrl */
14525                             class_number = ANYOF_CNTRL;
14526                         break;
14527                     case 'm':
14528                         if (memEQ(name_start, "alnu", 4)) /* alnum */
14529                             class_number = ANYOF_ALPHANUMERIC;
14530                         break;
14531                     case 'r':
14532                         if (memEQ(name_start, "lowe", 4)) /* lower */
14533                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
14534                         else if (memEQ(name_start, "uppe", 4)) /* upper */
14535                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
14536                         break;
14537                     case 't':
14538                         if (memEQ(name_start, "digi", 4)) /* digit */
14539                             class_number = ANYOF_DIGIT;
14540                         else if (memEQ(name_start, "prin", 4)) /* print */
14541                             class_number = ANYOF_PRINT;
14542                         else if (memEQ(name_start, "punc", 4)) /* punct */
14543                             class_number = ANYOF_PUNCT;
14544                         break;
14545                 }
14546                 break;
14547             case 6:
14548                 if (memEQ(name_start, "xdigit", 6))
14549                     class_number = ANYOF_XDIGIT;
14550                 break;
14551         }
14552
14553         /* If the name exactly matches a posix class name the class number will
14554          * here be set to it, and the input almost certainly was meant to be a
14555          * posix class, so we can skip further checking.  If instead the syntax
14556          * is exactly correct, but the name isn't one of the legal ones, we
14557          * will return that as an error below.  But if neither of these apply,
14558          * it could be that no posix class was intended at all, or that one
14559          * was, but there was a typo.  We tease these apart by doing fuzzy
14560          * matching on the name */
14561         if (class_number == OOB_NAMEDCLASS && found_problem) {
14562             const UV posix_names[][6] = {
14563                                                 { 'a', 'l', 'n', 'u', 'm' },
14564                                                 { 'a', 'l', 'p', 'h', 'a' },
14565                                                 { 'a', 's', 'c', 'i', 'i' },
14566                                                 { 'b', 'l', 'a', 'n', 'k' },
14567                                                 { 'c', 'n', 't', 'r', 'l' },
14568                                                 { 'd', 'i', 'g', 'i', 't' },
14569                                                 { 'g', 'r', 'a', 'p', 'h' },
14570                                                 { 'l', 'o', 'w', 'e', 'r' },
14571                                                 { 'p', 'r', 'i', 'n', 't' },
14572                                                 { 'p', 'u', 'n', 'c', 't' },
14573                                                 { 's', 'p', 'a', 'c', 'e' },
14574                                                 { 'u', 'p', 'p', 'e', 'r' },
14575                                                 { 'w', 'o', 'r', 'd' },
14576                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
14577                                             };
14578             /* The names of the above all have added NULs to make them the same
14579              * size, so we need to also have the real lengths */
14580             const UV posix_name_lengths[] = {
14581                                                 sizeof("alnum") - 1,
14582                                                 sizeof("alpha") - 1,
14583                                                 sizeof("ascii") - 1,
14584                                                 sizeof("blank") - 1,
14585                                                 sizeof("cntrl") - 1,
14586                                                 sizeof("digit") - 1,
14587                                                 sizeof("graph") - 1,
14588                                                 sizeof("lower") - 1,
14589                                                 sizeof("print") - 1,
14590                                                 sizeof("punct") - 1,
14591                                                 sizeof("space") - 1,
14592                                                 sizeof("upper") - 1,
14593                                                 sizeof("word")  - 1,
14594                                                 sizeof("xdigit")- 1
14595                                             };
14596             unsigned int i;
14597             int temp_max = max_distance;    /* Use a temporary, so if we
14598                                                reparse, we haven't changed the
14599                                                outer one */
14600
14601             /* Use a smaller max edit distance if we are missing one of the
14602              * delimiters */
14603             if (   has_opening_bracket + has_opening_colon < 2
14604                 || has_terminating_bracket + has_terminating_colon < 2)
14605             {
14606                 temp_max--;
14607             }
14608
14609             /* See if the input name is close to a legal one */
14610             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
14611
14612                 /* Short circuit call if the lengths are too far apart to be
14613                  * able to match */
14614                 if (abs( (int) (name_len - posix_name_lengths[i]))
14615                     > temp_max)
14616                 {
14617                     continue;
14618                 }
14619
14620                 if (edit_distance(input_text,
14621                                   posix_names[i],
14622                                   name_len,
14623                                   posix_name_lengths[i],
14624                                   temp_max
14625                                  )
14626                     > -1)
14627                 { /* If it is close, it probably was intended to be a class */
14628                     goto probably_meant_to_be;
14629                 }
14630             }
14631
14632             /* Here the input name is not close enough to a valid class name
14633              * for us to consider it to be intended to be a posix class.  If
14634              * we haven't already done so, and the parse found a character that
14635              * could have been terminators for the name, but which we absorbed
14636              * as typos during the first pass, repeat the parse, signalling it
14637              * to stop at that character */
14638             if (possible_end && possible_end != (char *) -1) {
14639                 possible_end = (char *) -1;
14640                 p = name_start;
14641                 goto parse_name;
14642             }
14643
14644             /* Here neither pass found a close-enough class name */
14645             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14646         }
14647
14648     probably_meant_to_be:
14649
14650         /* Here we think that a posix specification was intended.  Update any
14651          * parse pointer */
14652         if (updated_parse_ptr) {
14653             *updated_parse_ptr = (char *) p;
14654         }
14655
14656         /* If a posix class name was intended but incorrectly specified, we
14657          * output or return the warnings */
14658         if (found_problem) {
14659
14660             /* We set flags for these issues in the parse loop above instead of
14661              * adding them to the list of warnings, because we can parse it
14662              * twice, and we only want one warning instance */
14663             if (has_upper) {
14664                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
14665             }
14666             if (has_blank) {
14667                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14668             }
14669             if (has_semi_colon) {
14670                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14671             }
14672             else if (! has_terminating_colon) {
14673                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
14674             }
14675             if (! has_terminating_bracket) {
14676                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
14677             }
14678
14679             if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
14680                 *posix_warnings = RExC_warn_text;
14681             }
14682         }
14683         else if (class_number != OOB_NAMEDCLASS) {
14684             /* If it is a known class, return the class.  The class number
14685              * #defines are structured so each complement is +1 to the normal
14686              * one */
14687             return class_number + complement;
14688         }
14689         else if (! check_only) {
14690
14691             /* Here, it is an unrecognized class.  This is an error (unless the
14692             * call is to check only, which we've already handled above) */
14693             const char * const complement_string = (complement)
14694                                                    ? "^"
14695                                                    : "";
14696             RExC_parse = (char *) p;
14697             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
14698                         complement_string,
14699                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
14700         }
14701     }
14702
14703     return OOB_NAMEDCLASS;
14704 }
14705 #undef ADD_POSIX_WARNING
14706
14707 STATIC unsigned  int
14708 S_regex_set_precedence(const U8 my_operator) {
14709
14710     /* Returns the precedence in the (?[...]) construct of the input operator,
14711      * specified by its character representation.  The precedence follows
14712      * general Perl rules, but it extends this so that ')' and ']' have (low)
14713      * precedence even though they aren't really operators */
14714
14715     switch (my_operator) {
14716         case '!':
14717             return 5;
14718         case '&':
14719             return 4;
14720         case '^':
14721         case '|':
14722         case '+':
14723         case '-':
14724             return 3;
14725         case ')':
14726             return 2;
14727         case ']':
14728             return 1;
14729     }
14730
14731     NOT_REACHED; /* NOTREACHED */
14732     return 0;   /* Silence compiler warning */
14733 }
14734
14735 STATIC regnode *
14736 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
14737                     I32 *flagp, U32 depth,
14738                     char * const oregcomp_parse)
14739 {
14740     /* Handle the (?[...]) construct to do set operations */
14741
14742     U8 curchar;                     /* Current character being parsed */
14743     UV start, end;                  /* End points of code point ranges */
14744     SV* final = NULL;               /* The end result inversion list */
14745     SV* result_string;              /* 'final' stringified */
14746     AV* stack;                      /* stack of operators and operands not yet
14747                                        resolved */
14748     AV* fence_stack = NULL;         /* A stack containing the positions in
14749                                        'stack' of where the undealt-with left
14750                                        parens would be if they were actually
14751                                        put there */
14752     /* The 'VOL' (expanding to 'volatile') is a workaround for an optimiser bug
14753      * in Solaris Studio 12.3. See RT #127455 */
14754     VOL IV fence = 0;               /* Position of where most recent undealt-
14755                                        with left paren in stack is; -1 if none.
14756                                      */
14757     STRLEN len;                     /* Temporary */
14758     regnode* node;                  /* Temporary, and final regnode returned by
14759                                        this function */
14760     const bool save_fold = FOLD;    /* Temporary */
14761     char *save_end, *save_parse;    /* Temporaries */
14762     const bool in_locale = LOC;     /* we turn off /l during processing */
14763     AV* posix_warnings = NULL;
14764
14765     GET_RE_DEBUG_FLAGS_DECL;
14766
14767     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
14768
14769     if (in_locale) {
14770         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
14771     }
14772
14773     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
14774                                          This is required so that the compile
14775                                          time values are valid in all runtime
14776                                          cases */
14777
14778     /* This will return only an ANYOF regnode, or (unlikely) something smaller
14779      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
14780      * call regclass to handle '[]' so as to not have to reinvent its parsing
14781      * rules here (throwing away the size it computes each time).  And, we exit
14782      * upon an unescaped ']' that isn't one ending a regclass.  To do both
14783      * these things, we need to realize that something preceded by a backslash
14784      * is escaped, so we have to keep track of backslashes */
14785     if (SIZE_ONLY) {
14786         UV depth = 0; /* how many nested (?[...]) constructs */
14787
14788         while (RExC_parse < RExC_end) {
14789             SV* current = NULL;
14790
14791             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14792                                     TRUE /* Force /x */ );
14793
14794             switch (*RExC_parse) {
14795                 case '?':
14796                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
14797                     /* FALLTHROUGH */
14798                 default:
14799                     break;
14800                 case '\\':
14801                     /* Skip past this, so the next character gets skipped, after
14802                      * the switch */
14803                     RExC_parse++;
14804                     if (*RExC_parse == 'c') {
14805                             /* Skip the \cX notation for control characters */
14806                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14807                     }
14808                     break;
14809
14810                 case '[':
14811                 {
14812                     /* See if this is a [:posix:] class. */
14813                     bool is_posix_class = (OOB_NAMEDCLASS
14814                             < handle_possible_posix(pRExC_state,
14815                                                 RExC_parse + 1,
14816                                                 NULL,
14817                                                 NULL,
14818                                                 TRUE /* checking only */));
14819                     /* If it is a posix class, leave the parse pointer at the
14820                      * '[' to fool regclass() into thinking it is part of a
14821                      * '[[:posix:]]'. */
14822                     if (! is_posix_class) {
14823                         RExC_parse++;
14824                     }
14825
14826                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
14827                      * if multi-char folds are allowed.  */
14828                     if (!regclass(pRExC_state, flagp,depth+1,
14829                                   is_posix_class, /* parse the whole char
14830                                                      class only if not a
14831                                                      posix class */
14832                                   FALSE, /* don't allow multi-char folds */
14833                                   TRUE, /* silence non-portable warnings. */
14834                                   TRUE, /* strict */
14835                                   FALSE, /* Require return to be an ANYOF */
14836                                   &current,
14837                                   &posix_warnings
14838                                  ))
14839                         FAIL2("panic: regclass returned NULL to handle_sets, "
14840                               "flags=%#" UVxf, (UV) *flagp);
14841
14842                     /* function call leaves parse pointing to the ']', except
14843                      * if we faked it */
14844                     if (is_posix_class) {
14845                         RExC_parse--;
14846                     }
14847
14848                     SvREFCNT_dec(current);   /* In case it returned something */
14849                     break;
14850                 }
14851
14852                 case ']':
14853                     if (depth--) break;
14854                     RExC_parse++;
14855                     if (*RExC_parse == ')') {
14856                         node = reganode(pRExC_state, ANYOF, 0);
14857                         RExC_size += ANYOF_SKIP;
14858                         nextchar(pRExC_state);
14859                         Set_Node_Length(node,
14860                                 RExC_parse - oregcomp_parse + 1); /* MJD */
14861                         if (in_locale) {
14862                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
14863                         }
14864
14865                         return node;
14866                     }
14867                     goto no_close;
14868             }
14869
14870             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14871         }
14872
14873       no_close:
14874         /* We output the messages even if warnings are off, because we'll fail
14875          * the very next thing, and these give a likely diagnosis for that */
14876         if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
14877             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
14878         }
14879
14880         FAIL("Syntax error in (?[...])");
14881     }
14882
14883     /* Pass 2 only after this. */
14884     Perl_ck_warner_d(aTHX_
14885         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
14886         "The regex_sets feature is experimental" REPORT_LOCATION,
14887         REPORT_LOCATION_ARGS(RExC_parse));
14888
14889     /* Everything in this construct is a metacharacter.  Operands begin with
14890      * either a '\' (for an escape sequence), or a '[' for a bracketed
14891      * character class.  Any other character should be an operator, or
14892      * parenthesis for grouping.  Both types of operands are handled by calling
14893      * regclass() to parse them.  It is called with a parameter to indicate to
14894      * return the computed inversion list.  The parsing here is implemented via
14895      * a stack.  Each entry on the stack is a single character representing one
14896      * of the operators; or else a pointer to an operand inversion list. */
14897
14898 #define IS_OPERATOR(a) SvIOK(a)
14899 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
14900
14901     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
14902      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
14903      * with pronouncing it called it Reverse Polish instead, but now that YOU
14904      * know how to pronounce it you can use the correct term, thus giving due
14905      * credit to the person who invented it, and impressing your geek friends.
14906      * Wikipedia says that the pronounciation of "Ł" has been changing so that
14907      * it is now more like an English initial W (as in wonk) than an L.)
14908      *
14909      * This means that, for example, 'a | b & c' is stored on the stack as
14910      *
14911      * c  [4]
14912      * b  [3]
14913      * &  [2]
14914      * a  [1]
14915      * |  [0]
14916      *
14917      * where the numbers in brackets give the stack [array] element number.
14918      * In this implementation, parentheses are not stored on the stack.
14919      * Instead a '(' creates a "fence" so that the part of the stack below the
14920      * fence is invisible except to the corresponding ')' (this allows us to
14921      * replace testing for parens, by using instead subtraction of the fence
14922      * position).  As new operands are processed they are pushed onto the stack
14923      * (except as noted in the next paragraph).  New operators of higher
14924      * precedence than the current final one are inserted on the stack before
14925      * the lhs operand (so that when the rhs is pushed next, everything will be
14926      * in the correct positions shown above.  When an operator of equal or
14927      * lower precedence is encountered in parsing, all the stacked operations
14928      * of equal or higher precedence are evaluated, leaving the result as the
14929      * top entry on the stack.  This makes higher precedence operations
14930      * evaluate before lower precedence ones, and causes operations of equal
14931      * precedence to left associate.
14932      *
14933      * The only unary operator '!' is immediately pushed onto the stack when
14934      * encountered.  When an operand is encountered, if the top of the stack is
14935      * a '!", the complement is immediately performed, and the '!' popped.  The
14936      * resulting value is treated as a new operand, and the logic in the
14937      * previous paragraph is executed.  Thus in the expression
14938      *      [a] + ! [b]
14939      * the stack looks like
14940      *
14941      * !
14942      * a
14943      * +
14944      *
14945      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
14946      * becomes
14947      *
14948      * !b
14949      * a
14950      * +
14951      *
14952      * A ')' is treated as an operator with lower precedence than all the
14953      * aforementioned ones, which causes all operations on the stack above the
14954      * corresponding '(' to be evaluated down to a single resultant operand.
14955      * Then the fence for the '(' is removed, and the operand goes through the
14956      * algorithm above, without the fence.
14957      *
14958      * A separate stack is kept of the fence positions, so that the position of
14959      * the latest so-far unbalanced '(' is at the top of it.
14960      *
14961      * The ']' ending the construct is treated as the lowest operator of all,
14962      * so that everything gets evaluated down to a single operand, which is the
14963      * result */
14964
14965     sv_2mortal((SV *)(stack = newAV()));
14966     sv_2mortal((SV *)(fence_stack = newAV()));
14967
14968     while (RExC_parse < RExC_end) {
14969         I32 top_index;              /* Index of top-most element in 'stack' */
14970         SV** top_ptr;               /* Pointer to top 'stack' element */
14971         SV* current = NULL;         /* To contain the current inversion list
14972                                        operand */
14973         SV* only_to_avoid_leaks;
14974
14975         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14976                                 TRUE /* Force /x */ );
14977         if (RExC_parse >= RExC_end) {
14978             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
14979         }
14980
14981         curchar = UCHARAT(RExC_parse);
14982
14983 redo_curchar:
14984
14985 #ifdef ENABLE_REGEX_SETS_DEBUGGING
14986                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
14987         DEBUG_U(dump_regex_sets_structures(pRExC_state,
14988                                            stack, fence, fence_stack));
14989 #endif
14990
14991         top_index = av_tindex_skip_len_mg(stack);
14992
14993         switch (curchar) {
14994             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
14995             char stacked_operator;  /* The topmost operator on the 'stack'. */
14996             SV* lhs;                /* Operand to the left of the operator */
14997             SV* rhs;                /* Operand to the right of the operator */
14998             SV* fence_ptr;          /* Pointer to top element of the fence
14999                                        stack */
15000
15001             case '(':
15002
15003                 if (   RExC_parse < RExC_end - 1
15004                     && (UCHARAT(RExC_parse + 1) == '?'))
15005                 {
15006                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
15007                      * This happens when we have some thing like
15008                      *
15009                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
15010                      *   ...
15011                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
15012                      *
15013                      * Here we would be handling the interpolated
15014                      * '$thai_or_lao'.  We handle this by a recursive call to
15015                      * ourselves which returns the inversion list the
15016                      * interpolated expression evaluates to.  We use the flags
15017                      * from the interpolated pattern. */
15018                     U32 save_flags = RExC_flags;
15019                     const char * save_parse;
15020
15021                     RExC_parse += 2;        /* Skip past the '(?' */
15022                     save_parse = RExC_parse;
15023
15024                     /* Parse any flags for the '(?' */
15025                     parse_lparen_question_flags(pRExC_state);
15026
15027                     if (RExC_parse == save_parse  /* Makes sure there was at
15028                                                      least one flag (or else
15029                                                      this embedding wasn't
15030                                                      compiled) */
15031                         || RExC_parse >= RExC_end - 4
15032                         || UCHARAT(RExC_parse) != ':'
15033                         || UCHARAT(++RExC_parse) != '('
15034                         || UCHARAT(++RExC_parse) != '?'
15035                         || UCHARAT(++RExC_parse) != '[')
15036                     {
15037
15038                         /* In combination with the above, this moves the
15039                          * pointer to the point just after the first erroneous
15040                          * character (or if there are no flags, to where they
15041                          * should have been) */
15042                         if (RExC_parse >= RExC_end - 4) {
15043                             RExC_parse = RExC_end;
15044                         }
15045                         else if (RExC_parse != save_parse) {
15046                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15047                         }
15048                         vFAIL("Expecting '(?flags:(?[...'");
15049                     }
15050
15051                     /* Recurse, with the meat of the embedded expression */
15052                     RExC_parse++;
15053                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15054                                                     depth+1, oregcomp_parse);
15055
15056                     /* Here, 'current' contains the embedded expression's
15057                      * inversion list, and RExC_parse points to the trailing
15058                      * ']'; the next character should be the ')' */
15059                     RExC_parse++;
15060                     assert(UCHARAT(RExC_parse) == ')');
15061
15062                     /* Then the ')' matching the original '(' handled by this
15063                      * case: statement */
15064                     RExC_parse++;
15065                     assert(UCHARAT(RExC_parse) == ')');
15066
15067                     RExC_parse++;
15068                     RExC_flags = save_flags;
15069                     goto handle_operand;
15070                 }
15071
15072                 /* A regular '('.  Look behind for illegal syntax */
15073                 if (top_index - fence >= 0) {
15074                     /* If the top entry on the stack is an operator, it had
15075                      * better be a '!', otherwise the entry below the top
15076                      * operand should be an operator */
15077                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15078                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15079                         || (   IS_OPERAND(*top_ptr)
15080                             && (   top_index - fence < 1
15081                                 || ! (stacked_ptr = av_fetch(stack,
15082                                                              top_index - 1,
15083                                                              FALSE))
15084                                 || ! IS_OPERATOR(*stacked_ptr))))
15085                     {
15086                         RExC_parse++;
15087                         vFAIL("Unexpected '(' with no preceding operator");
15088                     }
15089                 }
15090
15091                 /* Stack the position of this undealt-with left paren */
15092                 av_push(fence_stack, newSViv(fence));
15093                 fence = top_index + 1;
15094                 break;
15095
15096             case '\\':
15097                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15098                  * multi-char folds are allowed.  */
15099                 if (!regclass(pRExC_state, flagp,depth+1,
15100                               TRUE, /* means parse just the next thing */
15101                               FALSE, /* don't allow multi-char folds */
15102                               FALSE, /* don't silence non-portable warnings.  */
15103                               TRUE,  /* strict */
15104                               FALSE, /* Require return to be an ANYOF */
15105                               &current,
15106                               NULL))
15107                 {
15108                     FAIL2("panic: regclass returned NULL to handle_sets, "
15109                           "flags=%#" UVxf, (UV) *flagp);
15110                 }
15111
15112                 /* regclass() will return with parsing just the \ sequence,
15113                  * leaving the parse pointer at the next thing to parse */
15114                 RExC_parse--;
15115                 goto handle_operand;
15116
15117             case '[':   /* Is a bracketed character class */
15118             {
15119                 /* See if this is a [:posix:] class. */
15120                 bool is_posix_class = (OOB_NAMEDCLASS
15121                             < handle_possible_posix(pRExC_state,
15122                                                 RExC_parse + 1,
15123                                                 NULL,
15124                                                 NULL,
15125                                                 TRUE /* checking only */));
15126                 /* If it is a posix class, leave the parse pointer at the '['
15127                  * to fool regclass() into thinking it is part of a
15128                  * '[[:posix:]]'. */
15129                 if (! is_posix_class) {
15130                     RExC_parse++;
15131                 }
15132
15133                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15134                  * multi-char folds are allowed.  */
15135                 if (!regclass(pRExC_state, flagp,depth+1,
15136                                 is_posix_class, /* parse the whole char
15137                                                     class only if not a
15138                                                     posix class */
15139                                 FALSE, /* don't allow multi-char folds */
15140                                 TRUE, /* silence non-portable warnings. */
15141                                 TRUE, /* strict */
15142                                 FALSE, /* Require return to be an ANYOF */
15143                                 &current,
15144                                 NULL
15145                                 ))
15146                 {
15147                     FAIL2("panic: regclass returned NULL to handle_sets, "
15148                           "flags=%#" UVxf, (UV) *flagp);
15149                 }
15150
15151                 /* function call leaves parse pointing to the ']', except if we
15152                  * faked it */
15153                 if (is_posix_class) {
15154                     RExC_parse--;
15155                 }
15156
15157                 goto handle_operand;
15158             }
15159
15160             case ']':
15161                 if (top_index >= 1) {
15162                     goto join_operators;
15163                 }
15164
15165                 /* Only a single operand on the stack: are done */
15166                 goto done;
15167
15168             case ')':
15169                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
15170                     RExC_parse++;
15171                     vFAIL("Unexpected ')'");
15172                 }
15173
15174                 /* If nothing after the fence, is missing an operand */
15175                 if (top_index - fence < 0) {
15176                     RExC_parse++;
15177                     goto bad_syntax;
15178                 }
15179                 /* If at least two things on the stack, treat this as an
15180                   * operator */
15181                 if (top_index - fence >= 1) {
15182                     goto join_operators;
15183                 }
15184
15185                 /* Here only a single thing on the fenced stack, and there is a
15186                  * fence.  Get rid of it */
15187                 fence_ptr = av_pop(fence_stack);
15188                 assert(fence_ptr);
15189                 fence = SvIV(fence_ptr) - 1;
15190                 SvREFCNT_dec_NN(fence_ptr);
15191                 fence_ptr = NULL;
15192
15193                 if (fence < 0) {
15194                     fence = 0;
15195                 }
15196
15197                 /* Having gotten rid of the fence, we pop the operand at the
15198                  * stack top and process it as a newly encountered operand */
15199                 current = av_pop(stack);
15200                 if (IS_OPERAND(current)) {
15201                     goto handle_operand;
15202                 }
15203
15204                 RExC_parse++;
15205                 goto bad_syntax;
15206
15207             case '&':
15208             case '|':
15209             case '+':
15210             case '-':
15211             case '^':
15212
15213                 /* These binary operators should have a left operand already
15214                  * parsed */
15215                 if (   top_index - fence < 0
15216                     || top_index - fence == 1
15217                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15218                     || ! IS_OPERAND(*top_ptr))
15219                 {
15220                     goto unexpected_binary;
15221                 }
15222
15223                 /* If only the one operand is on the part of the stack visible
15224                  * to us, we just place this operator in the proper position */
15225                 if (top_index - fence < 2) {
15226
15227                     /* Place the operator before the operand */
15228
15229                     SV* lhs = av_pop(stack);
15230                     av_push(stack, newSVuv(curchar));
15231                     av_push(stack, lhs);
15232                     break;
15233                 }
15234
15235                 /* But if there is something else on the stack, we need to
15236                  * process it before this new operator if and only if the
15237                  * stacked operation has equal or higher precedence than the
15238                  * new one */
15239
15240              join_operators:
15241
15242                 /* The operator on the stack is supposed to be below both its
15243                  * operands */
15244                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15245                     || IS_OPERAND(*stacked_ptr))
15246                 {
15247                     /* But if not, it's legal and indicates we are completely
15248                      * done if and only if we're currently processing a ']',
15249                      * which should be the final thing in the expression */
15250                     if (curchar == ']') {
15251                         goto done;
15252                     }
15253
15254                   unexpected_binary:
15255                     RExC_parse++;
15256                     vFAIL2("Unexpected binary operator '%c' with no "
15257                            "preceding operand", curchar);
15258                 }
15259                 stacked_operator = (char) SvUV(*stacked_ptr);
15260
15261                 if (regex_set_precedence(curchar)
15262                     > regex_set_precedence(stacked_operator))
15263                 {
15264                     /* Here, the new operator has higher precedence than the
15265                      * stacked one.  This means we need to add the new one to
15266                      * the stack to await its rhs operand (and maybe more
15267                      * stuff).  We put it before the lhs operand, leaving
15268                      * untouched the stacked operator and everything below it
15269                      * */
15270                     lhs = av_pop(stack);
15271                     assert(IS_OPERAND(lhs));
15272
15273                     av_push(stack, newSVuv(curchar));
15274                     av_push(stack, lhs);
15275                     break;
15276                 }
15277
15278                 /* Here, the new operator has equal or lower precedence than
15279                  * what's already there.  This means the operation already
15280                  * there should be performed now, before the new one. */
15281
15282                 rhs = av_pop(stack);
15283                 if (! IS_OPERAND(rhs)) {
15284
15285                     /* This can happen when a ! is not followed by an operand,
15286                      * like in /(?[\t &!])/ */
15287                     goto bad_syntax;
15288                 }
15289
15290                 lhs = av_pop(stack);
15291
15292                 if (! IS_OPERAND(lhs)) {
15293
15294                     /* This can happen when there is an empty (), like in
15295                      * /(?[[0]+()+])/ */
15296                     goto bad_syntax;
15297                 }
15298
15299                 switch (stacked_operator) {
15300                     case '&':
15301                         _invlist_intersection(lhs, rhs, &rhs);
15302                         break;
15303
15304                     case '|':
15305                     case '+':
15306                         _invlist_union(lhs, rhs, &rhs);
15307                         break;
15308
15309                     case '-':
15310                         _invlist_subtract(lhs, rhs, &rhs);
15311                         break;
15312
15313                     case '^':   /* The union minus the intersection */
15314                     {
15315                         SV* i = NULL;
15316                         SV* u = NULL;
15317
15318                         _invlist_union(lhs, rhs, &u);
15319                         _invlist_intersection(lhs, rhs, &i);
15320                         _invlist_subtract(u, i, &rhs);
15321                         SvREFCNT_dec_NN(i);
15322                         SvREFCNT_dec_NN(u);
15323                         break;
15324                     }
15325                 }
15326                 SvREFCNT_dec(lhs);
15327
15328                 /* Here, the higher precedence operation has been done, and the
15329                  * result is in 'rhs'.  We overwrite the stacked operator with
15330                  * the result.  Then we redo this code to either push the new
15331                  * operator onto the stack or perform any higher precedence
15332                  * stacked operation */
15333                 only_to_avoid_leaks = av_pop(stack);
15334                 SvREFCNT_dec(only_to_avoid_leaks);
15335                 av_push(stack, rhs);
15336                 goto redo_curchar;
15337
15338             case '!':   /* Highest priority, right associative */
15339
15340                 /* If what's already at the top of the stack is another '!",
15341                  * they just cancel each other out */
15342                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15343                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15344                 {
15345                     only_to_avoid_leaks = av_pop(stack);
15346                     SvREFCNT_dec(only_to_avoid_leaks);
15347                 }
15348                 else { /* Otherwise, since it's right associative, just push
15349                           onto the stack */
15350                     av_push(stack, newSVuv(curchar));
15351                 }
15352                 break;
15353
15354             default:
15355                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15356                 vFAIL("Unexpected character");
15357
15358           handle_operand:
15359
15360             /* Here 'current' is the operand.  If something is already on the
15361              * stack, we have to check if it is a !.  But first, the code above
15362              * may have altered the stack in the time since we earlier set
15363              * 'top_index'.  */
15364
15365             top_index = av_tindex_skip_len_mg(stack);
15366             if (top_index - fence >= 0) {
15367                 /* If the top entry on the stack is an operator, it had better
15368                  * be a '!', otherwise the entry below the top operand should
15369                  * be an operator */
15370                 top_ptr = av_fetch(stack, top_index, FALSE);
15371                 assert(top_ptr);
15372                 if (IS_OPERATOR(*top_ptr)) {
15373
15374                     /* The only permissible operator at the top of the stack is
15375                      * '!', which is applied immediately to this operand. */
15376                     curchar = (char) SvUV(*top_ptr);
15377                     if (curchar != '!') {
15378                         SvREFCNT_dec(current);
15379                         vFAIL2("Unexpected binary operator '%c' with no "
15380                                 "preceding operand", curchar);
15381                     }
15382
15383                     _invlist_invert(current);
15384
15385                     only_to_avoid_leaks = av_pop(stack);
15386                     SvREFCNT_dec(only_to_avoid_leaks);
15387
15388                     /* And we redo with the inverted operand.  This allows
15389                      * handling multiple ! in a row */
15390                     goto handle_operand;
15391                 }
15392                           /* Single operand is ok only for the non-binary ')'
15393                            * operator */
15394                 else if ((top_index - fence == 0 && curchar != ')')
15395                          || (top_index - fence > 0
15396                              && (! (stacked_ptr = av_fetch(stack,
15397                                                            top_index - 1,
15398                                                            FALSE))
15399                                  || IS_OPERAND(*stacked_ptr))))
15400                 {
15401                     SvREFCNT_dec(current);
15402                     vFAIL("Operand with no preceding operator");
15403                 }
15404             }
15405
15406             /* Here there was nothing on the stack or the top element was
15407              * another operand.  Just add this new one */
15408             av_push(stack, current);
15409
15410         } /* End of switch on next parse token */
15411
15412         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15413     } /* End of loop parsing through the construct */
15414
15415   done:
15416     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
15417         vFAIL("Unmatched (");
15418     }
15419
15420     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
15421         || ((final = av_pop(stack)) == NULL)
15422         || ! IS_OPERAND(final)
15423         || SvTYPE(final) != SVt_INVLIST
15424         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
15425     {
15426       bad_syntax:
15427         SvREFCNT_dec(final);
15428         vFAIL("Incomplete expression within '(?[ ])'");
15429     }
15430
15431     /* Here, 'final' is the resultant inversion list from evaluating the
15432      * expression.  Return it if so requested */
15433     if (return_invlist) {
15434         *return_invlist = final;
15435         return END;
15436     }
15437
15438     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15439      * expecting a string of ranges and individual code points */
15440     invlist_iterinit(final);
15441     result_string = newSVpvs("");
15442     while (invlist_iternext(final, &start, &end)) {
15443         if (start == end) {
15444             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
15445         }
15446         else {
15447             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
15448                                                      start,          end);
15449         }
15450     }
15451
15452     /* About to generate an ANYOF (or similar) node from the inversion list we
15453      * have calculated */
15454     save_parse = RExC_parse;
15455     RExC_parse = SvPV(result_string, len);
15456     save_end = RExC_end;
15457     RExC_end = RExC_parse + len;
15458
15459     /* We turn off folding around the call, as the class we have constructed
15460      * already has all folding taken into consideration, and we don't want
15461      * regclass() to add to that */
15462     RExC_flags &= ~RXf_PMf_FOLD;
15463     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15464      * folds are allowed.  */
15465     node = regclass(pRExC_state, flagp,depth+1,
15466                     FALSE, /* means parse the whole char class */
15467                     FALSE, /* don't allow multi-char folds */
15468                     TRUE, /* silence non-portable warnings.  The above may very
15469                              well have generated non-portable code points, but
15470                              they're valid on this machine */
15471                     FALSE, /* similarly, no need for strict */
15472                     FALSE, /* Require return to be an ANYOF */
15473                     NULL,
15474                     NULL
15475                 );
15476     if (!node)
15477         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#" UVxf,
15478                     PTR2UV(flagp));
15479
15480     /* Fix up the node type if we are in locale.  (We have pretended we are
15481      * under /u for the purposes of regclass(), as this construct will only
15482      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15483      * as to cause any warnings about bad locales to be output in regexec.c),
15484      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15485      * reason we above forbid optimization into something other than an ANYOF
15486      * node is simply to minimize the number of code changes in regexec.c.
15487      * Otherwise we would have to create new EXACTish node types and deal with
15488      * them.  This decision could be revisited should this construct become
15489      * popular.
15490      *
15491      * (One might think we could look at the resulting ANYOF node and suppress
15492      * the flag if everything is above 255, as those would be UTF-8 only,
15493      * but this isn't true, as the components that led to that result could
15494      * have been locale-affected, and just happen to cancel each other out
15495      * under UTF-8 locales.) */
15496     if (in_locale) {
15497         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15498
15499         assert(OP(node) == ANYOF);
15500
15501         OP(node) = ANYOFL;
15502         ANYOF_FLAGS(node)
15503                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
15504     }
15505
15506     if (save_fold) {
15507         RExC_flags |= RXf_PMf_FOLD;
15508     }
15509
15510     RExC_parse = save_parse + 1;
15511     RExC_end = save_end;
15512     SvREFCNT_dec_NN(final);
15513     SvREFCNT_dec_NN(result_string);
15514
15515     nextchar(pRExC_state);
15516     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
15517     return node;
15518 }
15519
15520 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15521
15522 STATIC void
15523 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
15524                              AV * stack, const IV fence, AV * fence_stack)
15525 {   /* Dumps the stacks in handle_regex_sets() */
15526
15527     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
15528     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
15529     SSize_t i;
15530
15531     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
15532
15533     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
15534
15535     if (stack_top < 0) {
15536         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
15537     }
15538     else {
15539         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
15540         for (i = stack_top; i >= 0; i--) {
15541             SV ** element_ptr = av_fetch(stack, i, FALSE);
15542             if (! element_ptr) {
15543             }
15544
15545             if (IS_OPERATOR(*element_ptr)) {
15546                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
15547                                             (int) i, (int) SvIV(*element_ptr));
15548             }
15549             else {
15550                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
15551                 sv_dump(*element_ptr);
15552             }
15553         }
15554     }
15555
15556     if (fence_stack_top < 0) {
15557         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
15558     }
15559     else {
15560         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
15561         for (i = fence_stack_top; i >= 0; i--) {
15562             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
15563             if (! element_ptr) {
15564             }
15565
15566             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
15567                                             (int) i, (int) SvIV(*element_ptr));
15568         }
15569     }
15570 }
15571
15572 #endif
15573
15574 #undef IS_OPERATOR
15575 #undef IS_OPERAND
15576
15577 STATIC void
15578 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
15579 {
15580     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
15581      * innocent-looking character class, like /[ks]/i won't have to go out to
15582      * disk to find the possible matches.
15583      *
15584      * This should be called only for a Latin1-range code points, cp, which is
15585      * known to be involved in a simple fold with other code points above
15586      * Latin1.  It would give false results if /aa has been specified.
15587      * Multi-char folds are outside the scope of this, and must be handled
15588      * specially.
15589      *
15590      * XXX It would be better to generate these via regen, in case a new
15591      * version of the Unicode standard adds new mappings, though that is not
15592      * really likely, and may be caught by the default: case of the switch
15593      * below. */
15594
15595     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
15596
15597     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
15598
15599     switch (cp) {
15600         case 'k':
15601         case 'K':
15602           *invlist =
15603              add_cp_to_invlist(*invlist, KELVIN_SIGN);
15604             break;
15605         case 's':
15606         case 'S':
15607           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
15608             break;
15609         case MICRO_SIGN:
15610           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
15611           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
15612             break;
15613         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
15614         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
15615           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
15616             break;
15617         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
15618           *invlist = add_cp_to_invlist(*invlist,
15619                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
15620             break;
15621
15622 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
15623
15624         case LATIN_SMALL_LETTER_SHARP_S:
15625           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
15626             break;
15627
15628 #endif
15629
15630 #if    UNICODE_MAJOR_VERSION < 3                                        \
15631    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
15632
15633         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
15634          * U+0131.  */
15635         case 'i':
15636         case 'I':
15637           *invlist =
15638              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
15639 #   if UNICODE_DOT_DOT_VERSION == 1
15640           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
15641 #   endif
15642             break;
15643 #endif
15644
15645         default:
15646             /* Use deprecated warning to increase the chances of this being
15647              * output */
15648             if (PASS2) {
15649                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
15650             }
15651             break;
15652     }
15653 }
15654
15655 STATIC void
15656 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
15657 {
15658     /* If the final parameter is NULL, output the elements of the array given
15659      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
15660      * pushed onto it, (creating if necessary) */
15661
15662     SV * msg;
15663     const bool first_is_fatal =  ! return_posix_warnings
15664                                 && ckDEAD(packWARN(WARN_REGEXP));
15665
15666     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
15667
15668     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
15669         if (return_posix_warnings) {
15670             if (! *return_posix_warnings) { /* mortalize to not leak if
15671                                                warnings are fatal */
15672                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
15673             }
15674             av_push(*return_posix_warnings, msg);
15675         }
15676         else {
15677             if (first_is_fatal) {           /* Avoid leaking this */
15678                 av_undef(posix_warnings);   /* This isn't necessary if the
15679                                                array is mortal, but is a
15680                                                fail-safe */
15681                 (void) sv_2mortal(msg);
15682                 if (PASS2) {
15683                     SAVEFREESV(RExC_rx_sv);
15684                 }
15685             }
15686             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
15687             SvREFCNT_dec_NN(msg);
15688         }
15689     }
15690 }
15691
15692 STATIC AV *
15693 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
15694 {
15695     /* This adds the string scalar <multi_string> to the array
15696      * <multi_char_matches>.  <multi_string> is known to have exactly
15697      * <cp_count> code points in it.  This is used when constructing a
15698      * bracketed character class and we find something that needs to match more
15699      * than a single character.
15700      *
15701      * <multi_char_matches> is actually an array of arrays.  Each top-level
15702      * element is an array that contains all the strings known so far that are
15703      * the same length.  And that length (in number of code points) is the same
15704      * as the index of the top-level array.  Hence, the [2] element is an
15705      * array, each element thereof is a string containing TWO code points;
15706      * while element [3] is for strings of THREE characters, and so on.  Since
15707      * this is for multi-char strings there can never be a [0] nor [1] element.
15708      *
15709      * When we rewrite the character class below, we will do so such that the
15710      * longest strings are written first, so that it prefers the longest
15711      * matching strings first.  This is done even if it turns out that any
15712      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
15713      * Christiansen has agreed that this is ok.  This makes the test for the
15714      * ligature 'ffi' come before the test for 'ff', for example */
15715
15716     AV* this_array;
15717     AV** this_array_ptr;
15718
15719     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
15720
15721     if (! multi_char_matches) {
15722         multi_char_matches = newAV();
15723     }
15724
15725     if (av_exists(multi_char_matches, cp_count)) {
15726         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
15727         this_array = *this_array_ptr;
15728     }
15729     else {
15730         this_array = newAV();
15731         av_store(multi_char_matches, cp_count,
15732                  (SV*) this_array);
15733     }
15734     av_push(this_array, multi_string);
15735
15736     return multi_char_matches;
15737 }
15738
15739 /* The names of properties whose definitions are not known at compile time are
15740  * stored in this SV, after a constant heading.  So if the length has been
15741  * changed since initialization, then there is a run-time definition. */
15742 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
15743                                         (SvCUR(listsv) != initial_listsv_len)
15744
15745 /* There is a restricted set of white space characters that are legal when
15746  * ignoring white space in a bracketed character class.  This generates the
15747  * code to skip them.
15748  *
15749  * There is a line below that uses the same white space criteria but is outside
15750  * this macro.  Both here and there must use the same definition */
15751 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
15752     STMT_START {                                                        \
15753         if (do_skip) {                                                  \
15754             while (isBLANK_A(UCHARAT(p)))                               \
15755             {                                                           \
15756                 p++;                                                    \
15757             }                                                           \
15758         }                                                               \
15759     } STMT_END
15760
15761 STATIC regnode *
15762 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
15763                  const bool stop_at_1,  /* Just parse the next thing, don't
15764                                            look for a full character class */
15765                  bool allow_multi_folds,
15766                  const bool silence_non_portable,   /* Don't output warnings
15767                                                        about too large
15768                                                        characters */
15769                  const bool strict,
15770                  bool optimizable,                  /* ? Allow a non-ANYOF return
15771                                                        node */
15772                  SV** ret_invlist, /* Return an inversion list, not a node */
15773                  AV** return_posix_warnings
15774           )
15775 {
15776     /* parse a bracketed class specification.  Most of these will produce an
15777      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
15778      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
15779      * under /i with multi-character folds: it will be rewritten following the
15780      * paradigm of this example, where the <multi-fold>s are characters which
15781      * fold to multiple character sequences:
15782      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
15783      * gets effectively rewritten as:
15784      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
15785      * reg() gets called (recursively) on the rewritten version, and this
15786      * function will return what it constructs.  (Actually the <multi-fold>s
15787      * aren't physically removed from the [abcdefghi], it's just that they are
15788      * ignored in the recursion by means of a flag:
15789      * <RExC_in_multi_char_class>.)
15790      *
15791      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
15792      * characters, with the corresponding bit set if that character is in the
15793      * list.  For characters above this, a range list or swash is used.  There
15794      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
15795      * determinable at compile time
15796      *
15797      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
15798      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
15799      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
15800      */
15801
15802     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
15803     IV range = 0;
15804     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
15805     regnode *ret;
15806     STRLEN numlen;
15807     int namedclass = OOB_NAMEDCLASS;
15808     char *rangebegin = NULL;
15809     bool need_class = 0;
15810     SV *listsv = NULL;
15811     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
15812                                       than just initialized.  */
15813     SV* properties = NULL;    /* Code points that match \p{} \P{} */
15814     SV* posixes = NULL;     /* Code points that match classes like [:word:],
15815                                extended beyond the Latin1 range.  These have to
15816                                be kept separate from other code points for much
15817                                of this function because their handling  is
15818                                different under /i, and for most classes under
15819                                /d as well */
15820     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
15821                                separate for a while from the non-complemented
15822                                versions because of complications with /d
15823                                matching */
15824     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
15825                                   treated more simply than the general case,
15826                                   leading to less compilation and execution
15827                                   work */
15828     UV element_count = 0;   /* Number of distinct elements in the class.
15829                                Optimizations may be possible if this is tiny */
15830     AV * multi_char_matches = NULL; /* Code points that fold to more than one
15831                                        character; used under /i */
15832     UV n;
15833     char * stop_ptr = RExC_end;    /* where to stop parsing */
15834
15835     /* ignore unescaped whitespace? */
15836     const bool skip_white = cBOOL(   ret_invlist
15837                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
15838
15839     /* Unicode properties are stored in a swash; this holds the current one
15840      * being parsed.  If this swash is the only above-latin1 component of the
15841      * character class, an optimization is to pass it directly on to the
15842      * execution engine.  Otherwise, it is set to NULL to indicate that there
15843      * are other things in the class that have to be dealt with at execution
15844      * time */
15845     SV* swash = NULL;           /* Code points that match \p{} \P{} */
15846
15847     /* Set if a component of this character class is user-defined; just passed
15848      * on to the engine */
15849     bool has_user_defined_property = FALSE;
15850
15851     /* inversion list of code points this node matches only when the target
15852      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
15853      * /d) */
15854     SV* has_upper_latin1_only_utf8_matches = NULL;
15855
15856     /* Inversion list of code points this node matches regardless of things
15857      * like locale, folding, utf8ness of the target string */
15858     SV* cp_list = NULL;
15859
15860     /* Like cp_list, but code points on this list need to be checked for things
15861      * that fold to/from them under /i */
15862     SV* cp_foldable_list = NULL;
15863
15864     /* Like cp_list, but code points on this list are valid only when the
15865      * runtime locale is UTF-8 */
15866     SV* only_utf8_locale_list = NULL;
15867
15868     /* In a range, if one of the endpoints is non-character-set portable,
15869      * meaning that it hard-codes a code point that may mean a different
15870      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
15871      * mnemonic '\t' which each mean the same character no matter which
15872      * character set the platform is on. */
15873     unsigned int non_portable_endpoint = 0;
15874
15875     /* Is the range unicode? which means on a platform that isn't 1-1 native
15876      * to Unicode (i.e. non-ASCII), each code point in it should be considered
15877      * to be a Unicode value.  */
15878     bool unicode_range = FALSE;
15879     bool invert = FALSE;    /* Is this class to be complemented */
15880
15881     bool warn_super = ALWAYS_WARN_SUPER;
15882
15883     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
15884         case we need to change the emitted regop to an EXACT. */
15885     const char * orig_parse = RExC_parse;
15886     const SSize_t orig_size = RExC_size;
15887     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
15888
15889     /* This variable is used to mark where the end in the input is of something
15890      * that looks like a POSIX construct but isn't.  During the parse, when
15891      * something looks like it could be such a construct is encountered, it is
15892      * checked for being one, but not if we've already checked this area of the
15893      * input.  Only after this position is reached do we check again */
15894     char *not_posix_region_end = RExC_parse - 1;
15895
15896     AV* posix_warnings = NULL;
15897     const bool do_posix_warnings =     return_posix_warnings
15898                                    || (PASS2 && ckWARN(WARN_REGEXP));
15899
15900     GET_RE_DEBUG_FLAGS_DECL;
15901
15902     PERL_ARGS_ASSERT_REGCLASS;
15903 #ifndef DEBUGGING
15904     PERL_UNUSED_ARG(depth);
15905 #endif
15906
15907     DEBUG_PARSE("clas");
15908
15909 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
15910     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
15911                                    && UNICODE_DOT_DOT_VERSION == 0)
15912     allow_multi_folds = FALSE;
15913 #endif
15914
15915     /* Assume we are going to generate an ANYOF node. */
15916     ret = reganode(pRExC_state,
15917                    (LOC)
15918                     ? ANYOFL
15919                     : ANYOF,
15920                    0);
15921
15922     if (SIZE_ONLY) {
15923         RExC_size += ANYOF_SKIP;
15924         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
15925     }
15926     else {
15927         ANYOF_FLAGS(ret) = 0;
15928
15929         RExC_emit += ANYOF_SKIP;
15930         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
15931         initial_listsv_len = SvCUR(listsv);
15932         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
15933     }
15934
15935     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15936
15937     assert(RExC_parse <= RExC_end);
15938
15939     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
15940         RExC_parse++;
15941         invert = TRUE;
15942         allow_multi_folds = FALSE;
15943         MARK_NAUGHTY(1);
15944         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15945     }
15946
15947     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
15948     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
15949         int maybe_class = handle_possible_posix(pRExC_state,
15950                                                 RExC_parse,
15951                                                 &not_posix_region_end,
15952                                                 NULL,
15953                                                 TRUE /* checking only */);
15954         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
15955             SAVEFREESV(RExC_rx_sv);
15956             ckWARN4reg(not_posix_region_end,
15957                     "POSIX syntax [%c %c] belongs inside character classes%s",
15958                     *RExC_parse, *RExC_parse,
15959                     (maybe_class == OOB_NAMEDCLASS)
15960                     ? ((POSIXCC_NOTYET(*RExC_parse))
15961                         ? " (but this one isn't implemented)"
15962                         : " (but this one isn't fully valid)")
15963                     : ""
15964                     );
15965             (void)ReREFCNT_inc(RExC_rx_sv);
15966         }
15967     }
15968
15969     /* If the caller wants us to just parse a single element, accomplish this
15970      * by faking the loop ending condition */
15971     if (stop_at_1 && RExC_end > RExC_parse) {
15972         stop_ptr = RExC_parse + 1;
15973     }
15974
15975     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
15976     if (UCHARAT(RExC_parse) == ']')
15977         goto charclassloop;
15978
15979     while (1) {
15980
15981         if (   posix_warnings
15982             && av_tindex_skip_len_mg(posix_warnings) >= 0
15983             && RExC_parse > not_posix_region_end)
15984         {
15985             /* Warnings about posix class issues are considered tentative until
15986              * we are far enough along in the parse that we can no longer
15987              * change our mind, at which point we either output them or add
15988              * them, if it has so specified, to what gets returned to the
15989              * caller.  This is done each time through the loop so that a later
15990              * class won't zap them before they have been dealt with. */
15991             output_or_return_posix_warnings(pRExC_state, posix_warnings,
15992                                             return_posix_warnings);
15993         }
15994
15995         if  (RExC_parse >= stop_ptr) {
15996             break;
15997         }
15998
15999         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16000
16001         if  (UCHARAT(RExC_parse) == ']') {
16002             break;
16003         }
16004
16005       charclassloop:
16006
16007         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
16008         save_value = value;
16009         save_prevvalue = prevvalue;
16010
16011         if (!range) {
16012             rangebegin = RExC_parse;
16013             element_count++;
16014             non_portable_endpoint = 0;
16015         }
16016         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
16017             value = utf8n_to_uvchr((U8*)RExC_parse,
16018                                    RExC_end - RExC_parse,
16019                                    &numlen, UTF8_ALLOW_DEFAULT);
16020             RExC_parse += numlen;
16021         }
16022         else
16023             value = UCHARAT(RExC_parse++);
16024
16025         if (value == '[') {
16026             char * posix_class_end;
16027             namedclass = handle_possible_posix(pRExC_state,
16028                                                RExC_parse,
16029                                                &posix_class_end,
16030                                                do_posix_warnings ? &posix_warnings : NULL,
16031                                                FALSE    /* die if error */);
16032             if (namedclass > OOB_NAMEDCLASS) {
16033
16034                 /* If there was an earlier attempt to parse this particular
16035                  * posix class, and it failed, it was a false alarm, as this
16036                  * successful one proves */
16037                 if (   posix_warnings
16038                     && av_tindex_skip_len_mg(posix_warnings) >= 0
16039                     && not_posix_region_end >= RExC_parse
16040                     && not_posix_region_end <= posix_class_end)
16041                 {
16042                     av_undef(posix_warnings);
16043                 }
16044
16045                 RExC_parse = posix_class_end;
16046             }
16047             else if (namedclass == OOB_NAMEDCLASS) {
16048                 not_posix_region_end = posix_class_end;
16049             }
16050             else {
16051                 namedclass = OOB_NAMEDCLASS;
16052             }
16053         }
16054         else if (   RExC_parse - 1 > not_posix_region_end
16055                  && MAYBE_POSIXCC(value))
16056         {
16057             (void) handle_possible_posix(
16058                         pRExC_state,
16059                         RExC_parse - 1,  /* -1 because parse has already been
16060                                             advanced */
16061                         &not_posix_region_end,
16062                         do_posix_warnings ? &posix_warnings : NULL,
16063                         TRUE /* checking only */);
16064         }
16065         else if (value == '\\') {
16066             /* Is a backslash; get the code point of the char after it */
16067
16068             if (RExC_parse >= RExC_end) {
16069                 vFAIL("Unmatched [");
16070             }
16071
16072             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16073                 value = utf8n_to_uvchr((U8*)RExC_parse,
16074                                    RExC_end - RExC_parse,
16075                                    &numlen, UTF8_ALLOW_DEFAULT);
16076                 RExC_parse += numlen;
16077             }
16078             else
16079                 value = UCHARAT(RExC_parse++);
16080
16081             /* Some compilers cannot handle switching on 64-bit integer
16082              * values, therefore value cannot be an UV.  Yes, this will
16083              * be a problem later if we want switch on Unicode.
16084              * A similar issue a little bit later when switching on
16085              * namedclass. --jhi */
16086
16087             /* If the \ is escaping white space when white space is being
16088              * skipped, it means that that white space is wanted literally, and
16089              * is already in 'value'.  Otherwise, need to translate the escape
16090              * into what it signifies. */
16091             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16092
16093             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16094             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16095             case 's':   namedclass = ANYOF_SPACE;       break;
16096             case 'S':   namedclass = ANYOF_NSPACE;      break;
16097             case 'd':   namedclass = ANYOF_DIGIT;       break;
16098             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16099             case 'v':   namedclass = ANYOF_VERTWS;      break;
16100             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16101             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16102             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16103             case 'N':  /* Handle \N{NAME} in class */
16104                 {
16105                     const char * const backslash_N_beg = RExC_parse - 2;
16106                     int cp_count;
16107
16108                     if (! grok_bslash_N(pRExC_state,
16109                                         NULL,      /* No regnode */
16110                                         &value,    /* Yes single value */
16111                                         &cp_count, /* Multiple code pt count */
16112                                         flagp,
16113                                         strict,
16114                                         depth)
16115                     ) {
16116
16117                         if (*flagp & NEED_UTF8)
16118                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16119                         if (*flagp & RESTART_PASS1)
16120                             return NULL;
16121
16122                         if (cp_count < 0) {
16123                             vFAIL("\\N in a character class must be a named character: \\N{...}");
16124                         }
16125                         else if (cp_count == 0) {
16126                             if (PASS2) {
16127                                 ckWARNreg(RExC_parse,
16128                                         "Ignoring zero length \\N{} in character class");
16129                             }
16130                         }
16131                         else { /* cp_count > 1 */
16132                             if (! RExC_in_multi_char_class) {
16133                                 if (invert || range || *RExC_parse == '-') {
16134                                     if (strict) {
16135                                         RExC_parse--;
16136                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
16137                                     }
16138                                     else if (PASS2) {
16139                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
16140                                     }
16141                                     break; /* <value> contains the first code
16142                                               point. Drop out of the switch to
16143                                               process it */
16144                                 }
16145                                 else {
16146                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
16147                                                  RExC_parse - backslash_N_beg);
16148                                     multi_char_matches
16149                                         = add_multi_match(multi_char_matches,
16150                                                           multi_char_N,
16151                                                           cp_count);
16152                                 }
16153                             }
16154                         } /* End of cp_count != 1 */
16155
16156                         /* This element should not be processed further in this
16157                          * class */
16158                         element_count--;
16159                         value = save_value;
16160                         prevvalue = save_prevvalue;
16161                         continue;   /* Back to top of loop to get next char */
16162                     }
16163
16164                     /* Here, is a single code point, and <value> contains it */
16165                     unicode_range = TRUE;   /* \N{} are Unicode */
16166                 }
16167                 break;
16168             case 'p':
16169             case 'P':
16170                 {
16171                 char *e;
16172
16173                 /* We will handle any undefined properties ourselves */
16174                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
16175                                        /* And we actually would prefer to get
16176                                         * the straight inversion list of the
16177                                         * swash, since we will be accessing it
16178                                         * anyway, to save a little time */
16179                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
16180
16181                 if (RExC_parse >= RExC_end)
16182                     vFAIL2("Empty \\%c", (U8)value);
16183                 if (*RExC_parse == '{') {
16184                     const U8 c = (U8)value;
16185                     e = strchr(RExC_parse, '}');
16186                     if (!e) {
16187                         RExC_parse++;
16188                         vFAIL2("Missing right brace on \\%c{}", c);
16189                     }
16190
16191                     RExC_parse++;
16192                     while (isSPACE(*RExC_parse)) {
16193                          RExC_parse++;
16194                     }
16195
16196                     if (UCHARAT(RExC_parse) == '^') {
16197
16198                         /* toggle.  (The rhs xor gets the single bit that
16199                          * differs between P and p; the other xor inverts just
16200                          * that bit) */
16201                         value ^= 'P' ^ 'p';
16202
16203                         RExC_parse++;
16204                         while (isSPACE(*RExC_parse)) {
16205                             RExC_parse++;
16206                         }
16207                     }
16208
16209                     if (e == RExC_parse)
16210                         vFAIL2("Empty \\%c{}", c);
16211
16212                     n = e - RExC_parse;
16213                     while (isSPACE(*(RExC_parse + n - 1)))
16214                         n--;
16215                 }   /* The \p isn't immediately followed by a '{' */
16216                 else if (! isALPHA(*RExC_parse)) {
16217                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16218                     vFAIL2("Character following \\%c must be '{' or a "
16219                            "single-character Unicode property name",
16220                            (U8) value);
16221                 }
16222                 else {
16223                     e = RExC_parse;
16224                     n = 1;
16225                 }
16226                 if (!SIZE_ONLY) {
16227                     SV* invlist;
16228                     char* name;
16229                     char* base_name;    /* name after any packages are stripped */
16230                     char* lookup_name = NULL;
16231                     const char * const colon_colon = "::";
16232
16233                     /* Try to get the definition of the property into
16234                      * <invlist>.  If /i is in effect, the effective property
16235                      * will have its name be <__NAME_i>.  The design is
16236                      * discussed in commit
16237                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
16238                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
16239                     SAVEFREEPV(name);
16240                     if (FOLD) {
16241                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
16242
16243                         /* The function call just below that uses this can fail
16244                          * to return, leaking memory if we don't do this */
16245                         SAVEFREEPV(lookup_name);
16246                     }
16247
16248                     /* Look up the property name, and get its swash and
16249                      * inversion list, if the property is found  */
16250                     SvREFCNT_dec(swash); /* Free any left-overs */
16251                     swash = _core_swash_init("utf8",
16252                                              (lookup_name)
16253                                               ? lookup_name
16254                                               : name,
16255                                              &PL_sv_undef,
16256                                              1, /* binary */
16257                                              0, /* not tr/// */
16258                                              NULL, /* No inversion list */
16259                                              &swash_init_flags
16260                                             );
16261                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
16262                         HV* curpkg = (IN_PERL_COMPILETIME)
16263                                       ? PL_curstash
16264                                       : CopSTASH(PL_curcop);
16265                         UV final_n = n;
16266                         bool has_pkg;
16267
16268                         if (swash) {    /* Got a swash but no inversion list.
16269                                            Something is likely wrong that will
16270                                            be sorted-out later */
16271                             SvREFCNT_dec_NN(swash);
16272                             swash = NULL;
16273                         }
16274
16275                         /* Here didn't find it.  It could be a an error (like a
16276                          * typo) in specifying a Unicode property, or it could
16277                          * be a user-defined property that will be available at
16278                          * run-time.  The names of these must begin with 'In'
16279                          * or 'Is' (after any packages are stripped off).  So
16280                          * if not one of those, or if we accept only
16281                          * compile-time properties, is an error; otherwise add
16282                          * it to the list for run-time look up. */
16283                         if ((base_name = rninstr(name, name + n,
16284                                                  colon_colon, colon_colon + 2)))
16285                         { /* Has ::.  We know this must be a user-defined
16286                              property */
16287                             base_name += 2;
16288                             final_n -= base_name - name;
16289                             has_pkg = TRUE;
16290                         }
16291                         else {
16292                             base_name = name;
16293                             has_pkg = FALSE;
16294                         }
16295
16296                         if (   final_n < 3
16297                             || base_name[0] != 'I'
16298                             || (base_name[1] != 's' && base_name[1] != 'n')
16299                             || ret_invlist)
16300                         {
16301                             const char * const msg
16302                                 = (has_pkg)
16303                                   ? "Illegal user-defined property name"
16304                                   : "Can't find Unicode property definition";
16305                             RExC_parse = e + 1;
16306
16307                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16308                             vFAIL3utf8f("%s \"%" UTF8f "\"",
16309                                 msg, UTF8fARG(UTF, n, name));
16310                         }
16311
16312                         /* If the property name doesn't already have a package
16313                          * name, add the current one to it so that it can be
16314                          * referred to outside it. [perl #121777] */
16315                         if (! has_pkg && curpkg) {
16316                             char* pkgname = HvNAME(curpkg);
16317                             if (strNE(pkgname, "main")) {
16318                                 char* full_name = Perl_form(aTHX_
16319                                                             "%s::%s",
16320                                                             pkgname,
16321                                                             name);
16322                                 n = strlen(full_name);
16323                                 name = savepvn(full_name, n);
16324                                 SAVEFREEPV(name);
16325                             }
16326                         }
16327                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
16328                                         (value == 'p' ? '+' : '!'),
16329                                         (FOLD) ? "__" : "",
16330                                         UTF8fARG(UTF, n, name),
16331                                         (FOLD) ? "_i" : "");
16332                         has_user_defined_property = TRUE;
16333                         optimizable = FALSE;    /* Will have to leave this an
16334                                                    ANYOF node */
16335
16336                         /* We don't know yet what this matches, so have to flag
16337                          * it */
16338                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16339                     }
16340                     else {
16341
16342                         /* Here, did get the swash and its inversion list.  If
16343                          * the swash is from a user-defined property, then this
16344                          * whole character class should be regarded as such */
16345                         if (swash_init_flags
16346                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16347                         {
16348                             has_user_defined_property = TRUE;
16349                         }
16350                         else if
16351                             /* We warn on matching an above-Unicode code point
16352                              * if the match would return true, except don't
16353                              * warn for \p{All}, which has exactly one element
16354                              * = 0 */
16355                             (_invlist_contains_cp(invlist, 0x110000)
16356                                 && (! (_invlist_len(invlist) == 1
16357                                        && *invlist_array(invlist) == 0)))
16358                         {
16359                             warn_super = TRUE;
16360                         }
16361
16362
16363                         /* Invert if asking for the complement */
16364                         if (value == 'P') {
16365                             _invlist_union_complement_2nd(properties,
16366                                                           invlist,
16367                                                           &properties);
16368
16369                             /* The swash can't be used as-is, because we've
16370                              * inverted things; delay removing it to here after
16371                              * have copied its invlist above */
16372                             SvREFCNT_dec_NN(swash);
16373                             swash = NULL;
16374                         }
16375                         else {
16376                             _invlist_union(properties, invlist, &properties);
16377                         }
16378                     }
16379                 }
16380                 RExC_parse = e + 1;
16381                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16382                                                 named */
16383
16384                 /* \p means they want Unicode semantics */
16385                 REQUIRE_UNI_RULES(flagp, NULL);
16386                 }
16387                 break;
16388             case 'n':   value = '\n';                   break;
16389             case 'r':   value = '\r';                   break;
16390             case 't':   value = '\t';                   break;
16391             case 'f':   value = '\f';                   break;
16392             case 'b':   value = '\b';                   break;
16393             case 'e':   value = ESC_NATIVE;             break;
16394             case 'a':   value = '\a';                   break;
16395             case 'o':
16396                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16397                 {
16398                     const char* error_msg;
16399                     bool valid = grok_bslash_o(&RExC_parse,
16400                                                &value,
16401                                                &error_msg,
16402                                                PASS2,   /* warnings only in
16403                                                            pass 2 */
16404                                                strict,
16405                                                silence_non_portable,
16406                                                UTF);
16407                     if (! valid) {
16408                         vFAIL(error_msg);
16409                     }
16410                 }
16411                 non_portable_endpoint++;
16412                 break;
16413             case 'x':
16414                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16415                 {
16416                     const char* error_msg;
16417                     bool valid = grok_bslash_x(&RExC_parse,
16418                                                &value,
16419                                                &error_msg,
16420                                                PASS2, /* Output warnings */
16421                                                strict,
16422                                                silence_non_portable,
16423                                                UTF);
16424                     if (! valid) {
16425                         vFAIL(error_msg);
16426                     }
16427                 }
16428                 non_portable_endpoint++;
16429                 break;
16430             case 'c':
16431                 value = grok_bslash_c(*RExC_parse++, PASS2);
16432                 non_portable_endpoint++;
16433                 break;
16434             case '0': case '1': case '2': case '3': case '4':
16435             case '5': case '6': case '7':
16436                 {
16437                     /* Take 1-3 octal digits */
16438                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16439                     numlen = (strict) ? 4 : 3;
16440                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16441                     RExC_parse += numlen;
16442                     if (numlen != 3) {
16443                         if (strict) {
16444                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16445                             vFAIL("Need exactly 3 octal digits");
16446                         }
16447                         else if (! SIZE_ONLY /* like \08, \178 */
16448                                  && numlen < 3
16449                                  && RExC_parse < RExC_end
16450                                  && isDIGIT(*RExC_parse)
16451                                  && ckWARN(WARN_REGEXP))
16452                         {
16453                             SAVEFREESV(RExC_rx_sv);
16454                             reg_warn_non_literal_string(
16455                                  RExC_parse + 1,
16456                                  form_short_octal_warning(RExC_parse, numlen));
16457                             (void)ReREFCNT_inc(RExC_rx_sv);
16458                         }
16459                     }
16460                     non_portable_endpoint++;
16461                     break;
16462                 }
16463             default:
16464                 /* Allow \_ to not give an error */
16465                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16466                     if (strict) {
16467                         vFAIL2("Unrecognized escape \\%c in character class",
16468                                (int)value);
16469                     }
16470                     else {
16471                         SAVEFREESV(RExC_rx_sv);
16472                         ckWARN2reg(RExC_parse,
16473                             "Unrecognized escape \\%c in character class passed through",
16474                             (int)value);
16475                         (void)ReREFCNT_inc(RExC_rx_sv);
16476                     }
16477                 }
16478                 break;
16479             }   /* End of switch on char following backslash */
16480         } /* end of handling backslash escape sequences */
16481
16482         /* Here, we have the current token in 'value' */
16483
16484         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
16485             U8 classnum;
16486
16487             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
16488              * literal, as is the character that began the false range, i.e.
16489              * the 'a' in the examples */
16490             if (range) {
16491                 if (!SIZE_ONLY) {
16492                     const int w = (RExC_parse >= rangebegin)
16493                                   ? RExC_parse - rangebegin
16494                                   : 0;
16495                     if (strict) {
16496                         vFAIL2utf8f(
16497                             "False [] range \"%" UTF8f "\"",
16498                             UTF8fARG(UTF, w, rangebegin));
16499                     }
16500                     else {
16501                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
16502                         ckWARN2reg(RExC_parse,
16503                             "False [] range \"%" UTF8f "\"",
16504                             UTF8fARG(UTF, w, rangebegin));
16505                         (void)ReREFCNT_inc(RExC_rx_sv);
16506                         cp_list = add_cp_to_invlist(cp_list, '-');
16507                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
16508                                                              prevvalue);
16509                     }
16510                 }
16511
16512                 range = 0; /* this was not a true range */
16513                 element_count += 2; /* So counts for three values */
16514             }
16515
16516             classnum = namedclass_to_classnum(namedclass);
16517
16518             if (LOC && namedclass < ANYOF_POSIXL_MAX
16519 #ifndef HAS_ISASCII
16520                 && classnum != _CC_ASCII
16521 #endif
16522             ) {
16523                 /* What the Posix classes (like \w, [:space:]) match in locale
16524                  * isn't knowable under locale until actual match time.  Room
16525                  * must be reserved (one time per outer bracketed class) to
16526                  * store such classes.  The space will contain a bit for each
16527                  * named class that is to be matched against.  This isn't
16528                  * needed for \p{} and pseudo-classes, as they are not affected
16529                  * by locale, and hence are dealt with separately */
16530                 if (! need_class) {
16531                     need_class = 1;
16532                     if (SIZE_ONLY) {
16533                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16534                     }
16535                     else {
16536                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16537                     }
16538                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
16539                     ANYOF_POSIXL_ZERO(ret);
16540
16541                     /* We can't change this into some other type of node
16542                      * (unless this is the only element, in which case there
16543                      * are nodes that mean exactly this) as has runtime
16544                      * dependencies */
16545                     optimizable = FALSE;
16546                 }
16547
16548                 /* Coverity thinks it is possible for this to be negative; both
16549                  * jhi and khw think it's not, but be safer */
16550                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16551                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
16552
16553                 /* See if it already matches the complement of this POSIX
16554                  * class */
16555                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16556                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
16557                                                             ? -1
16558                                                             : 1)))
16559                 {
16560                     posixl_matches_all = TRUE;
16561                     break;  /* No need to continue.  Since it matches both
16562                                e.g., \w and \W, it matches everything, and the
16563                                bracketed class can be optimized into qr/./s */
16564                 }
16565
16566                 /* Add this class to those that should be checked at runtime */
16567                 ANYOF_POSIXL_SET(ret, namedclass);
16568
16569                 /* The above-Latin1 characters are not subject to locale rules.
16570                  * Just add them, in the second pass, to the
16571                  * unconditionally-matched list */
16572                 if (! SIZE_ONLY) {
16573                     SV* scratch_list = NULL;
16574
16575                     /* Get the list of the above-Latin1 code points this
16576                      * matches */
16577                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
16578                                           PL_XPosix_ptrs[classnum],
16579
16580                                           /* Odd numbers are complements, like
16581                                            * NDIGIT, NASCII, ... */
16582                                           namedclass % 2 != 0,
16583                                           &scratch_list);
16584                     /* Checking if 'cp_list' is NULL first saves an extra
16585                      * clone.  Its reference count will be decremented at the
16586                      * next union, etc, or if this is the only instance, at the
16587                      * end of the routine */
16588                     if (! cp_list) {
16589                         cp_list = scratch_list;
16590                     }
16591                     else {
16592                         _invlist_union(cp_list, scratch_list, &cp_list);
16593                         SvREFCNT_dec_NN(scratch_list);
16594                     }
16595                     continue;   /* Go get next character */
16596                 }
16597             }
16598             else if (! SIZE_ONLY) {
16599
16600                 /* Here, not in pass1 (in that pass we skip calculating the
16601                  * contents of this class), and is not /l, or is a POSIX class
16602                  * for which /l doesn't matter (or is a Unicode property, which
16603                  * is skipped here). */
16604                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
16605                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
16606
16607                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
16608                          * nor /l make a difference in what these match,
16609                          * therefore we just add what they match to cp_list. */
16610                         if (classnum != _CC_VERTSPACE) {
16611                             assert(   namedclass == ANYOF_HORIZWS
16612                                    || namedclass == ANYOF_NHORIZWS);
16613
16614                             /* It turns out that \h is just a synonym for
16615                              * XPosixBlank */
16616                             classnum = _CC_BLANK;
16617                         }
16618
16619                         _invlist_union_maybe_complement_2nd(
16620                                 cp_list,
16621                                 PL_XPosix_ptrs[classnum],
16622                                 namedclass % 2 != 0,    /* Complement if odd
16623                                                           (NHORIZWS, NVERTWS)
16624                                                         */
16625                                 &cp_list);
16626                     }
16627                 }
16628                 else if (  UNI_SEMANTICS
16629                         || classnum == _CC_ASCII
16630                         || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
16631                                                   || classnum == _CC_XDIGIT)))
16632                 {
16633                     /* We usually have to worry about /d and /a affecting what
16634                      * POSIX classes match, with special code needed for /d
16635                      * because we won't know until runtime what all matches.
16636                      * But there is no extra work needed under /u, and
16637                      * [:ascii:] is unaffected by /a and /d; and :digit: and
16638                      * :xdigit: don't have runtime differences under /d.  So we
16639                      * can special case these, and avoid some extra work below,
16640                      * and at runtime. */
16641                     _invlist_union_maybe_complement_2nd(
16642                                                      simple_posixes,
16643                                                      PL_XPosix_ptrs[classnum],
16644                                                      namedclass % 2 != 0,
16645                                                      &simple_posixes);
16646                 }
16647                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
16648                            complement and use nposixes */
16649                     SV** posixes_ptr = namedclass % 2 == 0
16650                                        ? &posixes
16651                                        : &nposixes;
16652                     _invlist_union_maybe_complement_2nd(
16653                                                      *posixes_ptr,
16654                                                      PL_XPosix_ptrs[classnum],
16655                                                      namedclass % 2 != 0,
16656                                                      posixes_ptr);
16657                 }
16658             }
16659         } /* end of namedclass \blah */
16660
16661         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16662
16663         /* If 'range' is set, 'value' is the ending of a range--check its
16664          * validity.  (If value isn't a single code point in the case of a
16665          * range, we should have figured that out above in the code that
16666          * catches false ranges).  Later, we will handle each individual code
16667          * point in the range.  If 'range' isn't set, this could be the
16668          * beginning of a range, so check for that by looking ahead to see if
16669          * the next real character to be processed is the range indicator--the
16670          * minus sign */
16671
16672         if (range) {
16673 #ifdef EBCDIC
16674             /* For unicode ranges, we have to test that the Unicode as opposed
16675              * to the native values are not decreasing.  (Above 255, there is
16676              * no difference between native and Unicode) */
16677             if (unicode_range && prevvalue < 255 && value < 255) {
16678                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
16679                     goto backwards_range;
16680                 }
16681             }
16682             else
16683 #endif
16684             if (prevvalue > value) /* b-a */ {
16685                 int w;
16686 #ifdef EBCDIC
16687               backwards_range:
16688 #endif
16689                 w = RExC_parse - rangebegin;
16690                 vFAIL2utf8f(
16691                     "Invalid [] range \"%" UTF8f "\"",
16692                     UTF8fARG(UTF, w, rangebegin));
16693                 NOT_REACHED; /* NOTREACHED */
16694             }
16695         }
16696         else {
16697             prevvalue = value; /* save the beginning of the potential range */
16698             if (! stop_at_1     /* Can't be a range if parsing just one thing */
16699                 && *RExC_parse == '-')
16700             {
16701                 char* next_char_ptr = RExC_parse + 1;
16702
16703                 /* Get the next real char after the '-' */
16704                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
16705
16706                 /* If the '-' is at the end of the class (just before the ']',
16707                  * it is a literal minus; otherwise it is a range */
16708                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
16709                     RExC_parse = next_char_ptr;
16710
16711                     /* a bad range like \w-, [:word:]- ? */
16712                     if (namedclass > OOB_NAMEDCLASS) {
16713                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
16714                             const int w = RExC_parse >= rangebegin
16715                                           ?  RExC_parse - rangebegin
16716                                           : 0;
16717                             if (strict) {
16718                                 vFAIL4("False [] range \"%*.*s\"",
16719                                     w, w, rangebegin);
16720                             }
16721                             else if (PASS2) {
16722                                 vWARN4(RExC_parse,
16723                                     "False [] range \"%*.*s\"",
16724                                     w, w, rangebegin);
16725                             }
16726                         }
16727                         if (!SIZE_ONLY) {
16728                             cp_list = add_cp_to_invlist(cp_list, '-');
16729                         }
16730                         element_count++;
16731                     } else
16732                         range = 1;      /* yeah, it's a range! */
16733                     continue;   /* but do it the next time */
16734                 }
16735             }
16736         }
16737
16738         if (namedclass > OOB_NAMEDCLASS) {
16739             continue;
16740         }
16741
16742         /* Here, we have a single value this time through the loop, and
16743          * <prevvalue> is the beginning of the range, if any; or <value> if
16744          * not. */
16745
16746         /* non-Latin1 code point implies unicode semantics.  Must be set in
16747          * pass1 so is there for the whole of pass 2 */
16748         if (value > 255) {
16749             REQUIRE_UNI_RULES(flagp, NULL);
16750         }
16751
16752         /* Ready to process either the single value, or the completed range.
16753          * For single-valued non-inverted ranges, we consider the possibility
16754          * of multi-char folds.  (We made a conscious decision to not do this
16755          * for the other cases because it can often lead to non-intuitive
16756          * results.  For example, you have the peculiar case that:
16757          *  "s s" =~ /^[^\xDF]+$/i => Y
16758          *  "ss"  =~ /^[^\xDF]+$/i => N
16759          *
16760          * See [perl #89750] */
16761         if (FOLD && allow_multi_folds && value == prevvalue) {
16762             if (value == LATIN_SMALL_LETTER_SHARP_S
16763                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
16764                                                         value)))
16765             {
16766                 /* Here <value> is indeed a multi-char fold.  Get what it is */
16767
16768                 U8 foldbuf[UTF8_MAXBYTES_CASE];
16769                 STRLEN foldlen;
16770
16771                 UV folded = _to_uni_fold_flags(
16772                                 value,
16773                                 foldbuf,
16774                                 &foldlen,
16775                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
16776                                                    ? FOLD_FLAGS_NOMIX_ASCII
16777                                                    : 0)
16778                                 );
16779
16780                 /* Here, <folded> should be the first character of the
16781                  * multi-char fold of <value>, with <foldbuf> containing the
16782                  * whole thing.  But, if this fold is not allowed (because of
16783                  * the flags), <fold> will be the same as <value>, and should
16784                  * be processed like any other character, so skip the special
16785                  * handling */
16786                 if (folded != value) {
16787
16788                     /* Skip if we are recursed, currently parsing the class
16789                      * again.  Otherwise add this character to the list of
16790                      * multi-char folds. */
16791                     if (! RExC_in_multi_char_class) {
16792                         STRLEN cp_count = utf8_length(foldbuf,
16793                                                       foldbuf + foldlen);
16794                         SV* multi_fold = sv_2mortal(newSVpvs(""));
16795
16796                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
16797
16798                         multi_char_matches
16799                                         = add_multi_match(multi_char_matches,
16800                                                           multi_fold,
16801                                                           cp_count);
16802
16803                     }
16804
16805                     /* This element should not be processed further in this
16806                      * class */
16807                     element_count--;
16808                     value = save_value;
16809                     prevvalue = save_prevvalue;
16810                     continue;
16811                 }
16812             }
16813         }
16814
16815         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
16816             if (range) {
16817
16818                 /* If the range starts above 255, everything is portable and
16819                  * likely to be so for any forseeable character set, so don't
16820                  * warn. */
16821                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
16822                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
16823                 }
16824                 else if (prevvalue != value) {
16825
16826                     /* Under strict, ranges that stop and/or end in an ASCII
16827                      * printable should have each end point be a portable value
16828                      * for it (preferably like 'A', but we don't warn if it is
16829                      * a (portable) Unicode name or code point), and the range
16830                      * must be be all digits or all letters of the same case.
16831                      * Otherwise, the range is non-portable and unclear as to
16832                      * what it contains */
16833                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
16834                         && (          non_portable_endpoint
16835                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
16836                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
16837                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
16838                     ))) {
16839                         vWARN(RExC_parse, "Ranges of ASCII printables should"
16840                                           " be some subset of \"0-9\","
16841                                           " \"A-Z\", or \"a-z\"");
16842                     }
16843                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
16844                         SSize_t index_start;
16845                         SSize_t index_final;
16846
16847                         /* But the nature of Unicode and languages mean we
16848                          * can't do the same checks for above-ASCII ranges,
16849                          * except in the case of digit ones.  These should
16850                          * contain only digits from the same group of 10.  The
16851                          * ASCII case is handled just above.  0x660 is the
16852                          * first digit character beyond ASCII.  Hence here, the
16853                          * range could be a range of digits.  First some
16854                          * unlikely special cases.  Grandfather in that a range
16855                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
16856                          * if its starting value is one of the 10 digits prior
16857                          * to it.  This is because it is an alternate way of
16858                          * writing 19D1, and some people may expect it to be in
16859                          * that group.  But it is bad, because it won't give
16860                          * the expected results.  In Unicode 5.2 it was
16861                          * considered to be in that group (of 11, hence), but
16862                          * this was fixed in the next version */
16863
16864                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
16865                             goto warn_bad_digit_range;
16866                         }
16867                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
16868                                           &&     value <= 0x1D7FF))
16869                         {
16870                             /* This is the only other case currently in Unicode
16871                              * where the algorithm below fails.  The code
16872                              * points just above are the end points of a single
16873                              * range containing only decimal digits.  It is 5
16874                              * different series of 0-9.  All other ranges of
16875                              * digits currently in Unicode are just a single
16876                              * series.  (And mktables will notify us if a later
16877                              * Unicode version breaks this.)
16878                              *
16879                              * If the range being checked is at most 9 long,
16880                              * and the digit values represented are in
16881                              * numerical order, they are from the same series.
16882                              * */
16883                             if (         value - prevvalue > 9
16884                                 ||    (((    value - 0x1D7CE) % 10)
16885                                      <= (prevvalue - 0x1D7CE) % 10))
16886                             {
16887                                 goto warn_bad_digit_range;
16888                             }
16889                         }
16890                         else {
16891
16892                             /* For all other ranges of digits in Unicode, the
16893                              * algorithm is just to check if both end points
16894                              * are in the same series, which is the same range.
16895                              * */
16896                             index_start = _invlist_search(
16897                                                     PL_XPosix_ptrs[_CC_DIGIT],
16898                                                     prevvalue);
16899
16900                             /* Warn if the range starts and ends with a digit,
16901                              * and they are not in the same group of 10. */
16902                             if (   index_start >= 0
16903                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
16904                                 && (index_final =
16905                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16906                                                     value)) != index_start
16907                                 && index_final >= 0
16908                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
16909                             {
16910                               warn_bad_digit_range:
16911                                 vWARN(RExC_parse, "Ranges of digits should be"
16912                                                   " from the same group of"
16913                                                   " 10");
16914                             }
16915                         }
16916                     }
16917                 }
16918             }
16919             if ((! range || prevvalue == value) && non_portable_endpoint) {
16920                 if (isPRINT_A(value)) {
16921                     char literal[3];
16922                     unsigned d = 0;
16923                     if (isBACKSLASHED_PUNCT(value)) {
16924                         literal[d++] = '\\';
16925                     }
16926                     literal[d++] = (char) value;
16927                     literal[d++] = '\0';
16928
16929                     vWARN4(RExC_parse,
16930                            "\"%.*s\" is more clearly written simply as \"%s\"",
16931                            (int) (RExC_parse - rangebegin),
16932                            rangebegin,
16933                            literal
16934                         );
16935                 }
16936                 else if isMNEMONIC_CNTRL(value) {
16937                     vWARN4(RExC_parse,
16938                            "\"%.*s\" is more clearly written simply as \"%s\"",
16939                            (int) (RExC_parse - rangebegin),
16940                            rangebegin,
16941                            cntrl_to_mnemonic((U8) value)
16942                         );
16943                 }
16944             }
16945         }
16946
16947         /* Deal with this element of the class */
16948         if (! SIZE_ONLY) {
16949
16950 #ifndef EBCDIC
16951             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16952                                                      prevvalue, value);
16953 #else
16954             /* On non-ASCII platforms, for ranges that span all of 0..255, and
16955              * ones that don't require special handling, we can just add the
16956              * range like we do for ASCII platforms */
16957             if ((UNLIKELY(prevvalue == 0) && value >= 255)
16958                 || ! (prevvalue < 256
16959                       && (unicode_range
16960                           || (! non_portable_endpoint
16961                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
16962                                   || (isUPPER_A(prevvalue)
16963                                       && isUPPER_A(value)))))))
16964             {
16965                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16966                                                          prevvalue, value);
16967             }
16968             else {
16969                 /* Here, requires special handling.  This can be because it is
16970                  * a range whose code points are considered to be Unicode, and
16971                  * so must be individually translated into native, or because
16972                  * its a subrange of 'A-Z' or 'a-z' which each aren't
16973                  * contiguous in EBCDIC, but we have defined them to include
16974                  * only the "expected" upper or lower case ASCII alphabetics.
16975                  * Subranges above 255 are the same in native and Unicode, so
16976                  * can be added as a range */
16977                 U8 start = NATIVE_TO_LATIN1(prevvalue);
16978                 unsigned j;
16979                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
16980                 for (j = start; j <= end; j++) {
16981                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
16982                 }
16983                 if (value > 255) {
16984                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16985                                                              256, value);
16986                 }
16987             }
16988 #endif
16989         }
16990
16991         range = 0; /* this range (if it was one) is done now */
16992     } /* End of loop through all the text within the brackets */
16993
16994
16995     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
16996         output_or_return_posix_warnings(pRExC_state, posix_warnings,
16997                                         return_posix_warnings);
16998     }
16999
17000     /* If anything in the class expands to more than one character, we have to
17001      * deal with them by building up a substitute parse string, and recursively
17002      * calling reg() on it, instead of proceeding */
17003     if (multi_char_matches) {
17004         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
17005         I32 cp_count;
17006         STRLEN len;
17007         char *save_end = RExC_end;
17008         char *save_parse = RExC_parse;
17009         char *save_start = RExC_start;
17010         STRLEN prefix_end = 0;      /* We copy the character class after a
17011                                        prefix supplied here.  This is the size
17012                                        + 1 of that prefix */
17013         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
17014                                        a "|" */
17015         I32 reg_flags;
17016
17017         assert(! invert);
17018         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
17019
17020 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
17021            because too confusing */
17022         if (invert) {
17023             sv_catpv(substitute_parse, "(?:");
17024         }
17025 #endif
17026
17027         /* Look at the longest folds first */
17028         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
17029                         cp_count > 0;
17030                         cp_count--)
17031         {
17032
17033             if (av_exists(multi_char_matches, cp_count)) {
17034                 AV** this_array_ptr;
17035                 SV* this_sequence;
17036
17037                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
17038                                                  cp_count, FALSE);
17039                 while ((this_sequence = av_pop(*this_array_ptr)) !=
17040                                                                 &PL_sv_undef)
17041                 {
17042                     if (! first_time) {
17043                         sv_catpv(substitute_parse, "|");
17044                     }
17045                     first_time = FALSE;
17046
17047                     sv_catpv(substitute_parse, SvPVX(this_sequence));
17048                 }
17049             }
17050         }
17051
17052         /* If the character class contains anything else besides these
17053          * multi-character folds, have to include it in recursive parsing */
17054         if (element_count) {
17055             sv_catpv(substitute_parse, "|[");
17056             prefix_end = SvCUR(substitute_parse);
17057             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17058
17059             /* Put in a closing ']' only if not going off the end, as otherwise
17060              * we are adding something that really isn't there */
17061             if (RExC_parse < RExC_end) {
17062                 sv_catpv(substitute_parse, "]");
17063             }
17064         }
17065
17066         sv_catpv(substitute_parse, ")");
17067 #if 0
17068         if (invert) {
17069             /* This is a way to get the parse to skip forward a whole named
17070              * sequence instead of matching the 2nd character when it fails the
17071              * first */
17072             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17073         }
17074 #endif
17075
17076         /* Set up the data structure so that any errors will be properly
17077          * reported.  See the comments at the definition of
17078          * REPORT_LOCATION_ARGS for details */
17079         RExC_precomp_adj = orig_parse - RExC_precomp;
17080         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
17081         RExC_adjusted_start = RExC_start + prefix_end;
17082         RExC_end = RExC_parse + len;
17083         RExC_in_multi_char_class = 1;
17084         RExC_emit = (regnode *)orig_emit;
17085
17086         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17087
17088         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
17089
17090         /* And restore so can parse the rest of the pattern */
17091         RExC_parse = save_parse;
17092         RExC_start = RExC_adjusted_start = save_start;
17093         RExC_precomp_adj = 0;
17094         RExC_end = save_end;
17095         RExC_in_multi_char_class = 0;
17096         SvREFCNT_dec_NN(multi_char_matches);
17097         return ret;
17098     }
17099
17100     /* Here, we've gone through the entire class and dealt with multi-char
17101      * folds.  We are now in a position that we can do some checks to see if we
17102      * can optimize this ANYOF node into a simpler one, even in Pass 1.
17103      * Currently we only do two checks:
17104      * 1) is in the unlikely event that the user has specified both, eg. \w and
17105      *    \W under /l, then the class matches everything.  (This optimization
17106      *    is done only to make the optimizer code run later work.)
17107      * 2) if the character class contains only a single element (including a
17108      *    single range), we see if there is an equivalent node for it.
17109      * Other checks are possible */
17110     if (   optimizable
17111         && ! ret_invlist   /* Can't optimize if returning the constructed
17112                               inversion list */
17113         && (UNLIKELY(posixl_matches_all) || element_count == 1))
17114     {
17115         U8 op = END;
17116         U8 arg = 0;
17117
17118         if (UNLIKELY(posixl_matches_all)) {
17119             op = SANY;
17120         }
17121         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
17122                                                    class, like \w or [:digit:]
17123                                                    or \p{foo} */
17124
17125             /* All named classes are mapped into POSIXish nodes, with its FLAG
17126              * argument giving which class it is */
17127             switch ((I32)namedclass) {
17128                 case ANYOF_UNIPROP:
17129                     break;
17130
17131                 /* These don't depend on the charset modifiers.  They always
17132                  * match under /u rules */
17133                 case ANYOF_NHORIZWS:
17134                 case ANYOF_HORIZWS:
17135                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
17136                     /* FALLTHROUGH */
17137
17138                 case ANYOF_NVERTWS:
17139                 case ANYOF_VERTWS:
17140                     op = POSIXU;
17141                     goto join_posix;
17142
17143                 /* The actual POSIXish node for all the rest depends on the
17144                  * charset modifier.  The ones in the first set depend only on
17145                  * ASCII or, if available on this platform, also locale */
17146                 case ANYOF_ASCII:
17147                 case ANYOF_NASCII:
17148 #ifdef HAS_ISASCII
17149                     op = (LOC) ? POSIXL : POSIXA;
17150 #else
17151                     op = POSIXA;
17152 #endif
17153                     goto join_posix;
17154
17155                 /* The following don't have any matches in the upper Latin1
17156                  * range, hence /d is equivalent to /u for them.  Making it /u
17157                  * saves some branches at runtime */
17158                 case ANYOF_DIGIT:
17159                 case ANYOF_NDIGIT:
17160                 case ANYOF_XDIGIT:
17161                 case ANYOF_NXDIGIT:
17162                     if (! DEPENDS_SEMANTICS) {
17163                         goto treat_as_default;
17164                     }
17165
17166                     op = POSIXU;
17167                     goto join_posix;
17168
17169                 /* The following change to CASED under /i */
17170                 case ANYOF_LOWER:
17171                 case ANYOF_NLOWER:
17172                 case ANYOF_UPPER:
17173                 case ANYOF_NUPPER:
17174                     if (FOLD) {
17175                         namedclass = ANYOF_CASED + (namedclass % 2);
17176                     }
17177                     /* FALLTHROUGH */
17178
17179                 /* The rest have more possibilities depending on the charset.
17180                  * We take advantage of the enum ordering of the charset
17181                  * modifiers to get the exact node type, */
17182                 default:
17183                   treat_as_default:
17184                     op = POSIXD + get_regex_charset(RExC_flags);
17185                     if (op > POSIXA) { /* /aa is same as /a */
17186                         op = POSIXA;
17187                     }
17188
17189                   join_posix:
17190                     /* The odd numbered ones are the complements of the
17191                      * next-lower even number one */
17192                     if (namedclass % 2 == 1) {
17193                         invert = ! invert;
17194                         namedclass--;
17195                     }
17196                     arg = namedclass_to_classnum(namedclass);
17197                     break;
17198             }
17199         }
17200         else if (value == prevvalue) {
17201
17202             /* Here, the class consists of just a single code point */
17203
17204             if (invert) {
17205                 if (! LOC && value == '\n') {
17206                     op = REG_ANY; /* Optimize [^\n] */
17207                     *flagp |= HASWIDTH|SIMPLE;
17208                     MARK_NAUGHTY(1);
17209                 }
17210             }
17211             else if (value < 256 || UTF) {
17212
17213                 /* Optimize a single value into an EXACTish node, but not if it
17214                  * would require converting the pattern to UTF-8. */
17215                 op = compute_EXACTish(pRExC_state);
17216             }
17217         } /* Otherwise is a range */
17218         else if (! LOC) {   /* locale could vary these */
17219             if (prevvalue == '0') {
17220                 if (value == '9') {
17221                     arg = _CC_DIGIT;
17222                     op = POSIXA;
17223                 }
17224             }
17225             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
17226                 /* We can optimize A-Z or a-z, but not if they could match
17227                  * something like the KELVIN SIGN under /i. */
17228                 if (prevvalue == 'A') {
17229                     if (value == 'Z'
17230 #ifdef EBCDIC
17231                         && ! non_portable_endpoint
17232 #endif
17233                     ) {
17234                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
17235                         op = POSIXA;
17236                     }
17237                 }
17238                 else if (prevvalue == 'a') {
17239                     if (value == 'z'
17240 #ifdef EBCDIC
17241                         && ! non_portable_endpoint
17242 #endif
17243                     ) {
17244                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
17245                         op = POSIXA;
17246                     }
17247                 }
17248             }
17249         }
17250
17251         /* Here, we have changed <op> away from its initial value iff we found
17252          * an optimization */
17253         if (op != END) {
17254
17255             /* Throw away this ANYOF regnode, and emit the calculated one,
17256              * which should correspond to the beginning, not current, state of
17257              * the parse */
17258             const char * cur_parse = RExC_parse;
17259             RExC_parse = (char *)orig_parse;
17260             if ( SIZE_ONLY) {
17261                 if (! LOC) {
17262
17263                     /* To get locale nodes to not use the full ANYOF size would
17264                      * require moving the code above that writes the portions
17265                      * of it that aren't in other nodes to after this point.
17266                      * e.g.  ANYOF_POSIXL_SET */
17267                     RExC_size = orig_size;
17268                 }
17269             }
17270             else {
17271                 RExC_emit = (regnode *)orig_emit;
17272                 if (PL_regkind[op] == POSIXD) {
17273                     if (op == POSIXL) {
17274                         RExC_contains_locale = 1;
17275                     }
17276                     if (invert) {
17277                         op += NPOSIXD - POSIXD;
17278                     }
17279                 }
17280             }
17281
17282             ret = reg_node(pRExC_state, op);
17283
17284             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17285                 if (! SIZE_ONLY) {
17286                     FLAGS(ret) = arg;
17287                 }
17288                 *flagp |= HASWIDTH|SIMPLE;
17289             }
17290             else if (PL_regkind[op] == EXACT) {
17291                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17292                                            TRUE /* downgradable to EXACT */
17293                                            );
17294             }
17295
17296             RExC_parse = (char *) cur_parse;
17297
17298             SvREFCNT_dec(posixes);
17299             SvREFCNT_dec(nposixes);
17300             SvREFCNT_dec(simple_posixes);
17301             SvREFCNT_dec(cp_list);
17302             SvREFCNT_dec(cp_foldable_list);
17303             return ret;
17304         }
17305     }
17306
17307     if (SIZE_ONLY)
17308         return ret;
17309     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17310
17311     /* If folding, we calculate all characters that could fold to or from the
17312      * ones already on the list */
17313     if (cp_foldable_list) {
17314         if (FOLD) {
17315             UV start, end;      /* End points of code point ranges */
17316
17317             SV* fold_intersection = NULL;
17318             SV** use_list;
17319
17320             /* Our calculated list will be for Unicode rules.  For locale
17321              * matching, we have to keep a separate list that is consulted at
17322              * runtime only when the locale indicates Unicode rules.  For
17323              * non-locale, we just use the general list */
17324             if (LOC) {
17325                 use_list = &only_utf8_locale_list;
17326             }
17327             else {
17328                 use_list = &cp_list;
17329             }
17330
17331             /* Only the characters in this class that participate in folds need
17332              * be checked.  Get the intersection of this class and all the
17333              * possible characters that are foldable.  This can quickly narrow
17334              * down a large class */
17335             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17336                                   &fold_intersection);
17337
17338             /* The folds for all the Latin1 characters are hard-coded into this
17339              * program, but we have to go out to disk to get the others. */
17340             if (invlist_highest(cp_foldable_list) >= 256) {
17341
17342                 /* This is a hash that for a particular fold gives all
17343                  * characters that are involved in it */
17344                 if (! PL_utf8_foldclosures) {
17345                     _load_PL_utf8_foldclosures();
17346                 }
17347             }
17348
17349             /* Now look at the foldable characters in this class individually */
17350             invlist_iterinit(fold_intersection);
17351             while (invlist_iternext(fold_intersection, &start, &end)) {
17352                 UV j;
17353
17354                 /* Look at every character in the range */
17355                 for (j = start; j <= end; j++) {
17356                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17357                     STRLEN foldlen;
17358                     SV** listp;
17359
17360                     if (j < 256) {
17361
17362                         if (IS_IN_SOME_FOLD_L1(j)) {
17363
17364                             /* ASCII is always matched; non-ASCII is matched
17365                              * only under Unicode rules (which could happen
17366                              * under /l if the locale is a UTF-8 one */
17367                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17368                                 *use_list = add_cp_to_invlist(*use_list,
17369                                                             PL_fold_latin1[j]);
17370                             }
17371                             else {
17372                                 has_upper_latin1_only_utf8_matches
17373                                     = add_cp_to_invlist(
17374                                             has_upper_latin1_only_utf8_matches,
17375                                             PL_fold_latin1[j]);
17376                             }
17377                         }
17378
17379                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17380                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17381                         {
17382                             add_above_Latin1_folds(pRExC_state,
17383                                                    (U8) j,
17384                                                    use_list);
17385                         }
17386                         continue;
17387                     }
17388
17389                     /* Here is an above Latin1 character.  We don't have the
17390                      * rules hard-coded for it.  First, get its fold.  This is
17391                      * the simple fold, as the multi-character folds have been
17392                      * handled earlier and separated out */
17393                     _to_uni_fold_flags(j, foldbuf, &foldlen,
17394                                                         (ASCII_FOLD_RESTRICTED)
17395                                                         ? FOLD_FLAGS_NOMIX_ASCII
17396                                                         : 0);
17397
17398                     /* Single character fold of above Latin1.  Add everything in
17399                     * its fold closure to the list that this node should match.
17400                     * The fold closures data structure is a hash with the keys
17401                     * being the UTF-8 of every character that is folded to, like
17402                     * 'k', and the values each an array of all code points that
17403                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
17404                     * Multi-character folds are not included */
17405                     if ((listp = hv_fetch(PL_utf8_foldclosures,
17406                                         (char *) foldbuf, foldlen, FALSE)))
17407                     {
17408                         AV* list = (AV*) *listp;
17409                         IV k;
17410                         for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
17411                             SV** c_p = av_fetch(list, k, FALSE);
17412                             UV c;
17413                             assert(c_p);
17414
17415                             c = SvUV(*c_p);
17416
17417                             /* /aa doesn't allow folds between ASCII and non- */
17418                             if ((ASCII_FOLD_RESTRICTED
17419                                 && (isASCII(c) != isASCII(j))))
17420                             {
17421                                 continue;
17422                             }
17423
17424                             /* Folds under /l which cross the 255/256 boundary
17425                              * are added to a separate list.  (These are valid
17426                              * only when the locale is UTF-8.) */
17427                             if (c < 256 && LOC) {
17428                                 *use_list = add_cp_to_invlist(*use_list, c);
17429                                 continue;
17430                             }
17431
17432                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17433                             {
17434                                 cp_list = add_cp_to_invlist(cp_list, c);
17435                             }
17436                             else {
17437                                 /* Similarly folds involving non-ascii Latin1
17438                                 * characters under /d are added to their list */
17439                                 has_upper_latin1_only_utf8_matches
17440                                         = add_cp_to_invlist(
17441                                            has_upper_latin1_only_utf8_matches,
17442                                            c);
17443                             }
17444                         }
17445                     }
17446                 }
17447             }
17448             SvREFCNT_dec_NN(fold_intersection);
17449         }
17450
17451         /* Now that we have finished adding all the folds, there is no reason
17452          * to keep the foldable list separate */
17453         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17454         SvREFCNT_dec_NN(cp_foldable_list);
17455     }
17456
17457     /* And combine the result (if any) with any inversion lists from posix
17458      * classes.  The lists are kept separate up to now because we don't want to
17459      * fold the classes (folding of those is automatically handled by the swash
17460      * fetching code) */
17461     if (simple_posixes) {   /* These are the classes known to be unaffected by
17462                                /a, /aa, and /d */
17463         if (cp_list) {
17464             _invlist_union(cp_list, simple_posixes, &cp_list);
17465             SvREFCNT_dec_NN(simple_posixes);
17466         }
17467         else {
17468             cp_list = simple_posixes;
17469         }
17470     }
17471     if (posixes || nposixes) {
17472
17473         /* We have to adjust /a and /aa */
17474         if (AT_LEAST_ASCII_RESTRICTED) {
17475
17476             /* Under /a and /aa, nothing above ASCII matches these */
17477             if (posixes) {
17478                 _invlist_intersection(posixes,
17479                                     PL_XPosix_ptrs[_CC_ASCII],
17480                                     &posixes);
17481             }
17482
17483             /* Under /a and /aa, everything above ASCII matches these
17484              * complements */
17485             if (nposixes) {
17486                 _invlist_union_complement_2nd(nposixes,
17487                                               PL_XPosix_ptrs[_CC_ASCII],
17488                                               &nposixes);
17489             }
17490         }
17491
17492         if (! DEPENDS_SEMANTICS) {
17493
17494             /* For everything but /d, we can just add the current 'posixes' and
17495              * 'nposixes' to the main list */
17496             if (posixes) {
17497                 if (cp_list) {
17498                     _invlist_union(cp_list, posixes, &cp_list);
17499                     SvREFCNT_dec_NN(posixes);
17500                 }
17501                 else {
17502                     cp_list = posixes;
17503                 }
17504             }
17505             if (nposixes) {
17506                 if (cp_list) {
17507                     _invlist_union(cp_list, nposixes, &cp_list);
17508                     SvREFCNT_dec_NN(nposixes);
17509                 }
17510                 else {
17511                     cp_list = nposixes;
17512                 }
17513             }
17514         }
17515         else {
17516             /* Under /d, things like \w match upper Latin1 characters only if
17517              * the target string is in UTF-8.  But things like \W match all the
17518              * upper Latin1 characters if the target string is not in UTF-8.
17519              *
17520              * Handle the case where there something like \W separately */
17521             if (nposixes) {
17522                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
17523
17524                 /* A complemented posix class matches all upper Latin1
17525                  * characters if not in UTF-8.  And it matches just certain
17526                  * ones when in UTF-8.  That means those certain ones are
17527                  * matched regardless, so can just be added to the
17528                  * unconditional list */
17529                 if (cp_list) {
17530                     _invlist_union(cp_list, nposixes, &cp_list);
17531                     SvREFCNT_dec_NN(nposixes);
17532                     nposixes = NULL;
17533                 }
17534                 else {
17535                     cp_list = nposixes;
17536                 }
17537
17538                 /* Likewise for 'posixes' */
17539                 _invlist_union(posixes, cp_list, &cp_list);
17540
17541                 /* Likewise for anything else in the range that matched only
17542                  * under UTF-8 */
17543                 if (has_upper_latin1_only_utf8_matches) {
17544                     _invlist_union(cp_list,
17545                                    has_upper_latin1_only_utf8_matches,
17546                                    &cp_list);
17547                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17548                     has_upper_latin1_only_utf8_matches = NULL;
17549                 }
17550
17551                 /* If we don't match all the upper Latin1 characters regardless
17552                  * of UTF-8ness, we have to set a flag to match the rest when
17553                  * not in UTF-8 */
17554                 _invlist_subtract(only_non_utf8_list, cp_list,
17555                                   &only_non_utf8_list);
17556                 if (_invlist_len(only_non_utf8_list) != 0) {
17557                     ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17558                 }
17559             }
17560             else {
17561                 /* Here there were no complemented posix classes.  That means
17562                  * the upper Latin1 characters in 'posixes' match only when the
17563                  * target string is in UTF-8.  So we have to add them to the
17564                  * list of those types of code points, while adding the
17565                  * remainder to the unconditional list.
17566                  *
17567                  * First calculate what they are */
17568                 SV* nonascii_but_latin1_properties = NULL;
17569                 _invlist_intersection(posixes, PL_UpperLatin1,
17570                                       &nonascii_but_latin1_properties);
17571
17572                 /* And add them to the final list of such characters. */
17573                 _invlist_union(has_upper_latin1_only_utf8_matches,
17574                                nonascii_but_latin1_properties,
17575                                &has_upper_latin1_only_utf8_matches);
17576
17577                 /* Remove them from what now becomes the unconditional list */
17578                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
17579                                   &posixes);
17580
17581                 /* And add those unconditional ones to the final list */
17582                 if (cp_list) {
17583                     _invlist_union(cp_list, posixes, &cp_list);
17584                     SvREFCNT_dec_NN(posixes);
17585                     posixes = NULL;
17586                 }
17587                 else {
17588                     cp_list = posixes;
17589                 }
17590
17591                 SvREFCNT_dec(nonascii_but_latin1_properties);
17592
17593                 /* Get rid of any characters that we now know are matched
17594                  * unconditionally from the conditional list, which may make
17595                  * that list empty */
17596                 _invlist_subtract(has_upper_latin1_only_utf8_matches,
17597                                   cp_list,
17598                                   &has_upper_latin1_only_utf8_matches);
17599                 if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
17600                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17601                     has_upper_latin1_only_utf8_matches = NULL;
17602                 }
17603             }
17604         }
17605     }
17606
17607     /* And combine the result (if any) with any inversion list from properties.
17608      * The lists are kept separate up to now so that we can distinguish the two
17609      * in regards to matching above-Unicode.  A run-time warning is generated
17610      * if a Unicode property is matched against a non-Unicode code point. But,
17611      * we allow user-defined properties to match anything, without any warning,
17612      * and we also suppress the warning if there is a portion of the character
17613      * class that isn't a Unicode property, and which matches above Unicode, \W
17614      * or [\x{110000}] for example.
17615      * (Note that in this case, unlike the Posix one above, there is no
17616      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
17617      * forces Unicode semantics */
17618     if (properties) {
17619         if (cp_list) {
17620
17621             /* If it matters to the final outcome, see if a non-property
17622              * component of the class matches above Unicode.  If so, the
17623              * warning gets suppressed.  This is true even if just a single
17624              * such code point is specified, as, though not strictly correct if
17625              * another such code point is matched against, the fact that they
17626              * are using above-Unicode code points indicates they should know
17627              * the issues involved */
17628             if (warn_super) {
17629                 warn_super = ! (invert
17630                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
17631             }
17632
17633             _invlist_union(properties, cp_list, &cp_list);
17634             SvREFCNT_dec_NN(properties);
17635         }
17636         else {
17637             cp_list = properties;
17638         }
17639
17640         if (warn_super) {
17641             ANYOF_FLAGS(ret)
17642              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17643
17644             /* Because an ANYOF node is the only one that warns, this node
17645              * can't be optimized into something else */
17646             optimizable = FALSE;
17647         }
17648     }
17649
17650     /* Here, we have calculated what code points should be in the character
17651      * class.
17652      *
17653      * Now we can see about various optimizations.  Fold calculation (which we
17654      * did above) needs to take place before inversion.  Otherwise /[^k]/i
17655      * would invert to include K, which under /i would match k, which it
17656      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
17657      * folded until runtime */
17658
17659     /* If we didn't do folding, it's because some information isn't available
17660      * until runtime; set the run-time fold flag for these.  (We don't have to
17661      * worry about properties folding, as that is taken care of by the swash
17662      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
17663      * locales, or the class matches at least one 0-255 range code point */
17664     if (LOC && FOLD) {
17665
17666         /* Some things on the list might be unconditionally included because of
17667          * other components.  Remove them, and clean up the list if it goes to
17668          * 0 elements */
17669         if (only_utf8_locale_list && cp_list) {
17670             _invlist_subtract(only_utf8_locale_list, cp_list,
17671                               &only_utf8_locale_list);
17672
17673             if (_invlist_len(only_utf8_locale_list) == 0) {
17674                 SvREFCNT_dec_NN(only_utf8_locale_list);
17675                 only_utf8_locale_list = NULL;
17676             }
17677         }
17678         if (only_utf8_locale_list) {
17679             ANYOF_FLAGS(ret)
17680                  |=  ANYOFL_FOLD
17681                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
17682         }
17683         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
17684             UV start, end;
17685             invlist_iterinit(cp_list);
17686             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
17687                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
17688             }
17689             invlist_iterfinish(cp_list);
17690         }
17691     }
17692     else if (   DEPENDS_SEMANTICS
17693              && (    has_upper_latin1_only_utf8_matches
17694                  || (ANYOF_FLAGS(ret) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
17695     {
17696         OP(ret) = ANYOFD;
17697         optimizable = FALSE;
17698     }
17699
17700
17701     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
17702      * at compile time.  Besides not inverting folded locale now, we can't
17703      * invert if there are things such as \w, which aren't known until runtime
17704      * */
17705     if (cp_list
17706         && invert
17707         && OP(ret) != ANYOFD
17708         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
17709         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17710     {
17711         _invlist_invert(cp_list);
17712
17713         /* Any swash can't be used as-is, because we've inverted things */
17714         if (swash) {
17715             SvREFCNT_dec_NN(swash);
17716             swash = NULL;
17717         }
17718
17719         /* Clear the invert flag since have just done it here */
17720         invert = FALSE;
17721     }
17722
17723     if (ret_invlist) {
17724         assert(cp_list);
17725
17726         *ret_invlist = cp_list;
17727         SvREFCNT_dec(swash);
17728
17729         /* Discard the generated node */
17730         if (SIZE_ONLY) {
17731             RExC_size = orig_size;
17732         }
17733         else {
17734             RExC_emit = orig_emit;
17735         }
17736         return orig_emit;
17737     }
17738
17739     /* Some character classes are equivalent to other nodes.  Such nodes take
17740      * up less room and generally fewer operations to execute than ANYOF nodes.
17741      * Above, we checked for and optimized into some such equivalents for
17742      * certain common classes that are easy to test.  Getting to this point in
17743      * the code means that the class didn't get optimized there.  Since this
17744      * code is only executed in Pass 2, it is too late to save space--it has
17745      * been allocated in Pass 1, and currently isn't given back.  But turning
17746      * things into an EXACTish node can allow the optimizer to join it to any
17747      * adjacent such nodes.  And if the class is equivalent to things like /./,
17748      * expensive run-time swashes can be avoided.  Now that we have more
17749      * complete information, we can find things necessarily missed by the
17750      * earlier code.  Another possible "optimization" that isn't done is that
17751      * something like [Ee] could be changed into an EXACTFU.  khw tried this
17752      * and found that the ANYOF is faster, including for code points not in the
17753      * bitmap.  This still might make sense to do, provided it got joined with
17754      * an adjacent node(s) to create a longer EXACTFU one.  This could be
17755      * accomplished by creating a pseudo ANYOF_EXACTFU node type that the join
17756      * routine would know is joinable.  If that didn't happen, the node type
17757      * could then be made a straight ANYOF */
17758
17759     if (optimizable && cp_list && ! invert) {
17760         UV start, end;
17761         U8 op = END;  /* The optimzation node-type */
17762         int posix_class = -1;   /* Illegal value */
17763         const char * cur_parse= RExC_parse;
17764
17765         invlist_iterinit(cp_list);
17766         if (! invlist_iternext(cp_list, &start, &end)) {
17767
17768             /* Here, the list is empty.  This happens, for example, when a
17769              * Unicode property that doesn't match anything is the only element
17770              * in the character class (perluniprops.pod notes such properties).
17771              * */
17772             op = OPFAIL;
17773             *flagp |= HASWIDTH|SIMPLE;
17774         }
17775         else if (start == end) {    /* The range is a single code point */
17776             if (! invlist_iternext(cp_list, &start, &end)
17777
17778                     /* Don't do this optimization if it would require changing
17779                      * the pattern to UTF-8 */
17780                 && (start < 256 || UTF))
17781             {
17782                 /* Here, the list contains a single code point.  Can optimize
17783                  * into an EXACTish node */
17784
17785                 value = start;
17786
17787                 if (! FOLD) {
17788                     op = (LOC)
17789                          ? EXACTL
17790                          : EXACT;
17791                 }
17792                 else if (LOC) {
17793
17794                     /* A locale node under folding with one code point can be
17795                      * an EXACTFL, as its fold won't be calculated until
17796                      * runtime */
17797                     op = EXACTFL;
17798                 }
17799                 else {
17800
17801                     /* Here, we are generally folding, but there is only one
17802                      * code point to match.  If we have to, we use an EXACT
17803                      * node, but it would be better for joining with adjacent
17804                      * nodes in the optimization pass if we used the same
17805                      * EXACTFish node that any such are likely to be.  We can
17806                      * do this iff the code point doesn't participate in any
17807                      * folds.  For example, an EXACTF of a colon is the same as
17808                      * an EXACT one, since nothing folds to or from a colon. */
17809                     if (value < 256) {
17810                         if (IS_IN_SOME_FOLD_L1(value)) {
17811                             op = EXACT;
17812                         }
17813                     }
17814                     else {
17815                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
17816                             op = EXACT;
17817                         }
17818                     }
17819
17820                     /* If we haven't found the node type, above, it means we
17821                      * can use the prevailing one */
17822                     if (op == END) {
17823                         op = compute_EXACTish(pRExC_state);
17824                     }
17825                 }
17826             }
17827         }   /* End of first range contains just a single code point */
17828         else if (start == 0) {
17829             if (end == UV_MAX) {
17830                 op = SANY;
17831                 *flagp |= HASWIDTH|SIMPLE;
17832                 MARK_NAUGHTY(1);
17833             }
17834             else if (end == '\n' - 1
17835                     && invlist_iternext(cp_list, &start, &end)
17836                     && start == '\n' + 1 && end == UV_MAX)
17837             {
17838                 op = REG_ANY;
17839                 *flagp |= HASWIDTH|SIMPLE;
17840                 MARK_NAUGHTY(1);
17841             }
17842         }
17843         invlist_iterfinish(cp_list);
17844
17845         if (op == END) {
17846             const UV cp_list_len = _invlist_len(cp_list);
17847             const UV* cp_list_array = invlist_array(cp_list);
17848
17849             /* Here, didn't find an optimization.  See if this matches any of
17850              * the POSIX classes.  These run slightly faster for above-Unicode
17851              * code points, so don't bother with POSIXA ones nor the 2 that
17852              * have no above-Unicode matches.  We can avoid these checks unless
17853              * the ANYOF matches at least as high as the lowest POSIX one
17854              * (which was manually found to be \v.  The actual code point may
17855              * increase in later Unicode releases, if a higher code point is
17856              * assigned to be \v, but this code will never break.  It would
17857              * just mean we could execute the checks for posix optimizations
17858              * unnecessarily) */
17859
17860             if (cp_list_array[cp_list_len-1] > 0x2029) {
17861                 for (posix_class = 0;
17862                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
17863                      posix_class++)
17864                 {
17865                     int try_inverted;
17866                     if (posix_class == _CC_ASCII || posix_class == _CC_CNTRL) {
17867                         continue;
17868                     }
17869                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
17870
17871                         /* Check if matches normal or inverted */
17872                         if (_invlistEQ(cp_list,
17873                                        PL_XPosix_ptrs[posix_class],
17874                                        try_inverted))
17875                         {
17876                             op = (try_inverted)
17877                                  ? NPOSIXU
17878                                  : POSIXU;
17879                             *flagp |= HASWIDTH|SIMPLE;
17880                             goto found_posix;
17881                         }
17882                     }
17883                 }
17884               found_posix: ;
17885             }
17886         }
17887
17888         if (op != END) {
17889             RExC_parse = (char *)orig_parse;
17890             RExC_emit = (regnode *)orig_emit;
17891
17892             if (regarglen[op]) {
17893                 ret = reganode(pRExC_state, op, 0);
17894             } else {
17895                 ret = reg_node(pRExC_state, op);
17896             }
17897
17898             RExC_parse = (char *)cur_parse;
17899
17900             if (PL_regkind[op] == EXACT) {
17901                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17902                                            TRUE /* downgradable to EXACT */
17903                                           );
17904             }
17905             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17906                 FLAGS(ret) = posix_class;
17907             }
17908
17909             SvREFCNT_dec_NN(cp_list);
17910             return ret;
17911         }
17912     }
17913
17914     /* Here, <cp_list> contains all the code points we can determine at
17915      * compile time that match under all conditions.  Go through it, and
17916      * for things that belong in the bitmap, put them there, and delete from
17917      * <cp_list>.  While we are at it, see if everything above 255 is in the
17918      * list, and if so, set a flag to speed up execution */
17919
17920     populate_ANYOF_from_invlist(ret, &cp_list);
17921
17922     if (invert) {
17923         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
17924     }
17925
17926     /* Here, the bitmap has been populated with all the Latin1 code points that
17927      * always match.  Can now add to the overall list those that match only
17928      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
17929      * */
17930     if (has_upper_latin1_only_utf8_matches) {
17931         if (cp_list) {
17932             _invlist_union(cp_list,
17933                            has_upper_latin1_only_utf8_matches,
17934                            &cp_list);
17935             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17936         }
17937         else {
17938             cp_list = has_upper_latin1_only_utf8_matches;
17939         }
17940         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17941     }
17942
17943     /* If there is a swash and more than one element, we can't use the swash in
17944      * the optimization below. */
17945     if (swash && element_count > 1) {
17946         SvREFCNT_dec_NN(swash);
17947         swash = NULL;
17948     }
17949
17950     /* Note that the optimization of using 'swash' if it is the only thing in
17951      * the class doesn't have us change swash at all, so it can include things
17952      * that are also in the bitmap; otherwise we have purposely deleted that
17953      * duplicate information */
17954     set_ANYOF_arg(pRExC_state, ret, cp_list,
17955                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17956                    ? listsv : NULL,
17957                   only_utf8_locale_list,
17958                   swash, has_user_defined_property);
17959
17960     *flagp |= HASWIDTH|SIMPLE;
17961
17962     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
17963         RExC_contains_locale = 1;
17964     }
17965
17966     return ret;
17967 }
17968
17969 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
17970
17971 STATIC void
17972 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
17973                 regnode* const node,
17974                 SV* const cp_list,
17975                 SV* const runtime_defns,
17976                 SV* const only_utf8_locale_list,
17977                 SV* const swash,
17978                 const bool has_user_defined_property)
17979 {
17980     /* Sets the arg field of an ANYOF-type node 'node', using information about
17981      * the node passed-in.  If there is nothing outside the node's bitmap, the
17982      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
17983      * the count returned by add_data(), having allocated and stored an array,
17984      * av, that that count references, as follows:
17985      *  av[0] stores the character class description in its textual form.
17986      *        This is used later (regexec.c:Perl_regclass_swash()) to
17987      *        initialize the appropriate swash, and is also useful for dumping
17988      *        the regnode.  This is set to &PL_sv_undef if the textual
17989      *        description is not needed at run-time (as happens if the other
17990      *        elements completely define the class)
17991      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
17992      *        computed from av[0].  But if no further computation need be done,
17993      *        the swash is stored here now (and av[0] is &PL_sv_undef).
17994      *  av[2] stores the inversion list of code points that match only if the
17995      *        current locale is UTF-8
17996      *  av[3] stores the cp_list inversion list for use in addition or instead
17997      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
17998      *        (Otherwise everything needed is already in av[0] and av[1])
17999      *  av[4] is set if any component of the class is from a user-defined
18000      *        property; used only if av[3] exists */
18001
18002     UV n;
18003
18004     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
18005
18006     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
18007         assert(! (ANYOF_FLAGS(node)
18008                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
18009         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
18010     }
18011     else {
18012         AV * const av = newAV();
18013         SV *rv;
18014
18015         av_store(av, 0, (runtime_defns)
18016                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
18017         if (swash) {
18018             assert(cp_list);
18019             av_store(av, 1, swash);
18020             SvREFCNT_dec_NN(cp_list);
18021         }
18022         else {
18023             av_store(av, 1, &PL_sv_undef);
18024             if (cp_list) {
18025                 av_store(av, 3, cp_list);
18026                 av_store(av, 4, newSVuv(has_user_defined_property));
18027             }
18028         }
18029
18030         if (only_utf8_locale_list) {
18031             av_store(av, 2, only_utf8_locale_list);
18032         }
18033         else {
18034             av_store(av, 2, &PL_sv_undef);
18035         }
18036
18037         rv = newRV_noinc(MUTABLE_SV(av));
18038         n = add_data(pRExC_state, STR_WITH_LEN("s"));
18039         RExC_rxi->data->data[n] = (void*)rv;
18040         ARG_SET(node, n);
18041     }
18042 }
18043
18044 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
18045 SV *
18046 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
18047                                         const regnode* node,
18048                                         bool doinit,
18049                                         SV** listsvp,
18050                                         SV** only_utf8_locale_ptr,
18051                                         SV** output_invlist)
18052
18053 {
18054     /* For internal core use only.
18055      * Returns the swash for the input 'node' in the regex 'prog'.
18056      * If <doinit> is 'true', will attempt to create the swash if not already
18057      *    done.
18058      * If <listsvp> is non-null, will return the printable contents of the
18059      *    swash.  This can be used to get debugging information even before the
18060      *    swash exists, by calling this function with 'doinit' set to false, in
18061      *    which case the components that will be used to eventually create the
18062      *    swash are returned  (in a printable form).
18063      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
18064      *    store an inversion list of code points that should match only if the
18065      *    execution-time locale is a UTF-8 one.
18066      * If <output_invlist> is not NULL, it is where this routine is to store an
18067      *    inversion list of the code points that would be instead returned in
18068      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
18069      *    when this parameter is used, is just the non-code point data that
18070      *    will go into creating the swash.  This currently should be just
18071      *    user-defined properties whose definitions were not known at compile
18072      *    time.  Using this parameter allows for easier manipulation of the
18073      *    swash's data by the caller.  It is illegal to call this function with
18074      *    this parameter set, but not <listsvp>
18075      *
18076      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
18077      * that, in spite of this function's name, the swash it returns may include
18078      * the bitmap data as well */
18079
18080     SV *sw  = NULL;
18081     SV *si  = NULL;         /* Input swash initialization string */
18082     SV* invlist = NULL;
18083
18084     RXi_GET_DECL(prog,progi);
18085     const struct reg_data * const data = prog ? progi->data : NULL;
18086
18087     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
18088     assert(! output_invlist || listsvp);
18089
18090     if (data && data->count) {
18091         const U32 n = ARG(node);
18092
18093         if (data->what[n] == 's') {
18094             SV * const rv = MUTABLE_SV(data->data[n]);
18095             AV * const av = MUTABLE_AV(SvRV(rv));
18096             SV **const ary = AvARRAY(av);
18097             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
18098
18099             si = *ary;  /* ary[0] = the string to initialize the swash with */
18100
18101             if (av_tindex_skip_len_mg(av) >= 2) {
18102                 if (only_utf8_locale_ptr
18103                     && ary[2]
18104                     && ary[2] != &PL_sv_undef)
18105                 {
18106                     *only_utf8_locale_ptr = ary[2];
18107                 }
18108                 else {
18109                     assert(only_utf8_locale_ptr);
18110                     *only_utf8_locale_ptr = NULL;
18111                 }
18112
18113                 /* Elements 3 and 4 are either both present or both absent. [3]
18114                  * is any inversion list generated at compile time; [4]
18115                  * indicates if that inversion list has any user-defined
18116                  * properties in it. */
18117                 if (av_tindex_skip_len_mg(av) >= 3) {
18118                     invlist = ary[3];
18119                     if (SvUV(ary[4])) {
18120                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
18121                     }
18122                 }
18123                 else {
18124                     invlist = NULL;
18125                 }
18126             }
18127
18128             /* Element [1] is reserved for the set-up swash.  If already there,
18129              * return it; if not, create it and store it there */
18130             if (ary[1] && SvROK(ary[1])) {
18131                 sw = ary[1];
18132             }
18133             else if (doinit && ((si && si != &PL_sv_undef)
18134                                  || (invlist && invlist != &PL_sv_undef))) {
18135                 assert(si);
18136                 sw = _core_swash_init("utf8", /* the utf8 package */
18137                                       "", /* nameless */
18138                                       si,
18139                                       1, /* binary */
18140                                       0, /* not from tr/// */
18141                                       invlist,
18142                                       &swash_init_flags);
18143                 (void)av_store(av, 1, sw);
18144             }
18145         }
18146     }
18147
18148     /* If requested, return a printable version of what this swash matches */
18149     if (listsvp) {
18150         SV* matches_string = NULL;
18151
18152         /* The swash should be used, if possible, to get the data, as it
18153          * contains the resolved data.  But this function can be called at
18154          * compile-time, before everything gets resolved, in which case we
18155          * return the currently best available information, which is the string
18156          * that will eventually be used to do that resolving, 'si' */
18157         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
18158             && (si && si != &PL_sv_undef))
18159         {
18160             /* Here, we only have 'si' (and possibly some passed-in data in
18161              * 'invlist', which is handled below)  If the caller only wants
18162              * 'si', use that.  */
18163             if (! output_invlist) {
18164                 matches_string = newSVsv(si);
18165             }
18166             else {
18167                 /* But if the caller wants an inversion list of the node, we
18168                  * need to parse 'si' and place as much as possible in the
18169                  * desired output inversion list, making 'matches_string' only
18170                  * contain the currently unresolvable things */
18171                 const char *si_string = SvPVX(si);
18172                 STRLEN remaining = SvCUR(si);
18173                 UV prev_cp = 0;
18174                 U8 count = 0;
18175
18176                 /* Ignore everything before the first new-line */
18177                 while (*si_string != '\n' && remaining > 0) {
18178                     si_string++;
18179                     remaining--;
18180                 }
18181                 assert(remaining > 0);
18182
18183                 si_string++;
18184                 remaining--;
18185
18186                 while (remaining > 0) {
18187
18188                     /* The data consists of just strings defining user-defined
18189                      * property names, but in prior incarnations, and perhaps
18190                      * somehow from pluggable regex engines, it could still
18191                      * hold hex code point definitions.  Each component of a
18192                      * range would be separated by a tab, and each range by a
18193                      * new-line.  If these are found, instead add them to the
18194                      * inversion list */
18195                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
18196                                      |PERL_SCAN_SILENT_NON_PORTABLE;
18197                     STRLEN len = remaining;
18198                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
18199
18200                     /* If the hex decode routine found something, it should go
18201                      * up to the next \n */
18202                     if (   *(si_string + len) == '\n') {
18203                         if (count) {    /* 2nd code point on line */
18204                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
18205                         }
18206                         else {
18207                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
18208                         }
18209                         count = 0;
18210                         goto prepare_for_next_iteration;
18211                     }
18212
18213                     /* If the hex decode was instead for the lower range limit,
18214                      * save it, and go parse the upper range limit */
18215                     if (*(si_string + len) == '\t') {
18216                         assert(count == 0);
18217
18218                         prev_cp = cp;
18219                         count = 1;
18220                       prepare_for_next_iteration:
18221                         si_string += len + 1;
18222                         remaining -= len + 1;
18223                         continue;
18224                     }
18225
18226                     /* Here, didn't find a legal hex number.  Just add it from
18227                      * here to the next \n */
18228
18229                     remaining -= len;
18230                     while (*(si_string + len) != '\n' && remaining > 0) {
18231                         remaining--;
18232                         len++;
18233                     }
18234                     if (*(si_string + len) == '\n') {
18235                         len++;
18236                         remaining--;
18237                     }
18238                     if (matches_string) {
18239                         sv_catpvn(matches_string, si_string, len - 1);
18240                     }
18241                     else {
18242                         matches_string = newSVpvn(si_string, len - 1);
18243                     }
18244                     si_string += len;
18245                     sv_catpvs(matches_string, " ");
18246                 } /* end of loop through the text */
18247
18248                 assert(matches_string);
18249                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
18250                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
18251                 }
18252             } /* end of has an 'si' but no swash */
18253         }
18254
18255         /* If we have a swash in place, its equivalent inversion list was above
18256          * placed into 'invlist'.  If not, this variable may contain a stored
18257          * inversion list which is information beyond what is in 'si' */
18258         if (invlist) {
18259
18260             /* Again, if the caller doesn't want the output inversion list, put
18261              * everything in 'matches-string' */
18262             if (! output_invlist) {
18263                 if ( ! matches_string) {
18264                     matches_string = newSVpvs("\n");
18265                 }
18266                 sv_catsv(matches_string, invlist_contents(invlist,
18267                                                   TRUE /* traditional style */
18268                                                   ));
18269             }
18270             else if (! *output_invlist) {
18271                 *output_invlist = invlist_clone(invlist);
18272             }
18273             else {
18274                 _invlist_union(*output_invlist, invlist, output_invlist);
18275             }
18276         }
18277
18278         *listsvp = matches_string;
18279     }
18280
18281     return sw;
18282 }
18283 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18284
18285 /* reg_skipcomment()
18286
18287    Absorbs an /x style # comment from the input stream,
18288    returning a pointer to the first character beyond the comment, or if the
18289    comment terminates the pattern without anything following it, this returns
18290    one past the final character of the pattern (in other words, RExC_end) and
18291    sets the REG_RUN_ON_COMMENT_SEEN flag.
18292
18293    Note it's the callers responsibility to ensure that we are
18294    actually in /x mode
18295
18296 */
18297
18298 PERL_STATIC_INLINE char*
18299 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18300 {
18301     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18302
18303     assert(*p == '#');
18304
18305     while (p < RExC_end) {
18306         if (*(++p) == '\n') {
18307             return p+1;
18308         }
18309     }
18310
18311     /* we ran off the end of the pattern without ending the comment, so we have
18312      * to add an \n when wrapping */
18313     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18314     return p;
18315 }
18316
18317 STATIC void
18318 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18319                                 char ** p,
18320                                 const bool force_to_xmod
18321                          )
18322 {
18323     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18324      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18325      * is /x whitespace, advance '*p' so that on exit it points to the first
18326      * byte past all such white space and comments */
18327
18328     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18329
18330     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18331
18332     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18333
18334     for (;;) {
18335         if (RExC_end - (*p) >= 3
18336             && *(*p)     == '('
18337             && *(*p + 1) == '?'
18338             && *(*p + 2) == '#')
18339         {
18340             while (*(*p) != ')') {
18341                 if ((*p) == RExC_end)
18342                     FAIL("Sequence (?#... not terminated");
18343                 (*p)++;
18344             }
18345             (*p)++;
18346             continue;
18347         }
18348
18349         if (use_xmod) {
18350             const char * save_p = *p;
18351             while ((*p) < RExC_end) {
18352                 STRLEN len;
18353                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18354                     (*p) += len;
18355                 }
18356                 else if (*(*p) == '#') {
18357                     (*p) = reg_skipcomment(pRExC_state, (*p));
18358                 }
18359                 else {
18360                     break;
18361                 }
18362             }
18363             if (*p != save_p) {
18364                 continue;
18365             }
18366         }
18367
18368         break;
18369     }
18370
18371     return;
18372 }
18373
18374 /* nextchar()
18375
18376    Advances the parse position by one byte, unless that byte is the beginning
18377    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
18378    those two cases, the parse position is advanced beyond all such comments and
18379    white space.
18380
18381    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
18382 */
18383
18384 STATIC void
18385 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
18386 {
18387     PERL_ARGS_ASSERT_NEXTCHAR;
18388
18389     if (RExC_parse < RExC_end) {
18390         assert(   ! UTF
18391                || UTF8_IS_INVARIANT(*RExC_parse)
18392                || UTF8_IS_START(*RExC_parse));
18393
18394         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
18395
18396         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
18397                                 FALSE /* Don't force /x */ );
18398     }
18399 }
18400
18401 STATIC regnode *
18402 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
18403 {
18404     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
18405      * space.  In pass1, it aligns and increments RExC_size; in pass2,
18406      * RExC_emit */
18407
18408     regnode * const ret = RExC_emit;
18409     GET_RE_DEBUG_FLAGS_DECL;
18410
18411     PERL_ARGS_ASSERT_REGNODE_GUTS;
18412
18413     assert(extra_size >= regarglen[op]);
18414
18415     if (SIZE_ONLY) {
18416         SIZE_ALIGN(RExC_size);
18417         RExC_size += 1 + extra_size;
18418         return(ret);
18419     }
18420     if (RExC_emit >= RExC_emit_bound)
18421         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
18422                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
18423
18424     NODE_ALIGN_FILL(ret);
18425 #ifndef RE_TRACK_PATTERN_OFFSETS
18426     PERL_UNUSED_ARG(name);
18427 #else
18428     if (RExC_offsets) {         /* MJD */
18429         MJD_OFFSET_DEBUG(
18430               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
18431               name, __LINE__,
18432               PL_reg_name[op],
18433               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
18434                 ? "Overwriting end of array!\n" : "OK",
18435               (UV)(RExC_emit - RExC_emit_start),
18436               (UV)(RExC_parse - RExC_start),
18437               (UV)RExC_offsets[0]));
18438         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
18439     }
18440 #endif
18441     return(ret);
18442 }
18443
18444 /*
18445 - reg_node - emit a node
18446 */
18447 STATIC regnode *                        /* Location. */
18448 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
18449 {
18450     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
18451
18452     PERL_ARGS_ASSERT_REG_NODE;
18453
18454     assert(regarglen[op] == 0);
18455
18456     if (PASS2) {
18457         regnode *ptr = ret;
18458         FILL_ADVANCE_NODE(ptr, op);
18459         RExC_emit = ptr;
18460     }
18461     return(ret);
18462 }
18463
18464 /*
18465 - reganode - emit a node with an argument
18466 */
18467 STATIC regnode *                        /* Location. */
18468 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
18469 {
18470     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
18471
18472     PERL_ARGS_ASSERT_REGANODE;
18473
18474     assert(regarglen[op] == 1);
18475
18476     if (PASS2) {
18477         regnode *ptr = ret;
18478         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
18479         RExC_emit = ptr;
18480     }
18481     return(ret);
18482 }
18483
18484 STATIC regnode *
18485 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
18486 {
18487     /* emit a node with U32 and I32 arguments */
18488
18489     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
18490
18491     PERL_ARGS_ASSERT_REG2LANODE;
18492
18493     assert(regarglen[op] == 2);
18494
18495     if (PASS2) {
18496         regnode *ptr = ret;
18497         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
18498         RExC_emit = ptr;
18499     }
18500     return(ret);
18501 }
18502
18503 /*
18504 - reginsert - insert an operator in front of already-emitted operand
18505 *
18506 * Means relocating the operand.
18507 *
18508 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
18509 * set up NEXT_OFF() of the inserted node if needed. Something like this:
18510 *
18511 * reginsert(pRExC, OPFAIL, orig_emit, depth+1);
18512 * if (PASS2)
18513 *     NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
18514 *
18515 */
18516 STATIC void
18517 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth)
18518 {
18519     regnode *src;
18520     regnode *dst;
18521     regnode *place;
18522     const int offset = regarglen[(U8)op];
18523     const int size = NODE_STEP_REGNODE + offset;
18524     GET_RE_DEBUG_FLAGS_DECL;
18525
18526     PERL_ARGS_ASSERT_REGINSERT;
18527     PERL_UNUSED_CONTEXT;
18528     PERL_UNUSED_ARG(depth);
18529 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
18530     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
18531     if (SIZE_ONLY) {
18532         RExC_size += size;
18533         return;
18534     }
18535     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
18536                                     studying. If this is wrong then we need to adjust RExC_recurse
18537                                     below like we do with RExC_open_parens/RExC_close_parens. */
18538     src = RExC_emit;
18539     RExC_emit += size;
18540     dst = RExC_emit;
18541     if (RExC_open_parens) {
18542         int paren;
18543         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
18544         /* remember that RExC_npar is rex->nparens + 1,
18545          * iow it is 1 more than the number of parens seen in
18546          * the pattern so far. */
18547         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
18548             /* note, RExC_open_parens[0] is the start of the
18549              * regex, it can't move. RExC_close_parens[0] is the end
18550              * of the regex, it *can* move. */
18551             if ( paren && RExC_open_parens[paren] >= operand ) {
18552                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
18553                 RExC_open_parens[paren] += size;
18554             } else {
18555                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
18556             }
18557             if ( RExC_close_parens[paren] >= operand ) {
18558                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
18559                 RExC_close_parens[paren] += size;
18560             } else {
18561                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
18562             }
18563         }
18564     }
18565     if (RExC_end_op)
18566         RExC_end_op += size;
18567
18568     while (src > operand) {
18569         StructCopy(--src, --dst, regnode);
18570 #ifdef RE_TRACK_PATTERN_OFFSETS
18571         if (RExC_offsets) {     /* MJD 20010112 */
18572             MJD_OFFSET_DEBUG(
18573                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
18574                   "reg_insert",
18575                   __LINE__,
18576                   PL_reg_name[op],
18577                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
18578                     ? "Overwriting end of array!\n" : "OK",
18579                   (UV)(src - RExC_emit_start),
18580                   (UV)(dst - RExC_emit_start),
18581                   (UV)RExC_offsets[0]));
18582             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
18583             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
18584         }
18585 #endif
18586     }
18587
18588
18589     place = operand;            /* Op node, where operand used to be. */
18590 #ifdef RE_TRACK_PATTERN_OFFSETS
18591     if (RExC_offsets) {         /* MJD */
18592         MJD_OFFSET_DEBUG(
18593               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
18594               "reginsert",
18595               __LINE__,
18596               PL_reg_name[op],
18597               (UV)(place - RExC_emit_start) > RExC_offsets[0]
18598               ? "Overwriting end of array!\n" : "OK",
18599               (UV)(place - RExC_emit_start),
18600               (UV)(RExC_parse - RExC_start),
18601               (UV)RExC_offsets[0]));
18602         Set_Node_Offset(place, RExC_parse);
18603         Set_Node_Length(place, 1);
18604     }
18605 #endif
18606     src = NEXTOPER(place);
18607     FILL_ADVANCE_NODE(place, op);
18608     Zero(src, offset, regnode);
18609 }
18610
18611 /*
18612 - regtail - set the next-pointer at the end of a node chain of p to val.
18613 - SEE ALSO: regtail_study
18614 */
18615 STATIC void
18616 S_regtail(pTHX_ RExC_state_t * pRExC_state,
18617                 const regnode * const p,
18618                 const regnode * const val,
18619                 const U32 depth)
18620 {
18621     regnode *scan;
18622     GET_RE_DEBUG_FLAGS_DECL;
18623
18624     PERL_ARGS_ASSERT_REGTAIL;
18625 #ifndef DEBUGGING
18626     PERL_UNUSED_ARG(depth);
18627 #endif
18628
18629     if (SIZE_ONLY)
18630         return;
18631
18632     /* Find last node. */
18633     scan = (regnode *) p;
18634     for (;;) {
18635         regnode * const temp = regnext(scan);
18636         DEBUG_PARSE_r({
18637             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
18638             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18639             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
18640                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
18641                     (temp == NULL ? "->" : ""),
18642                     (temp == NULL ? PL_reg_name[OP(val)] : "")
18643             );
18644         });
18645         if (temp == NULL)
18646             break;
18647         scan = temp;
18648     }
18649
18650     if (reg_off_by_arg[OP(scan)]) {
18651         ARG_SET(scan, val - scan);
18652     }
18653     else {
18654         NEXT_OFF(scan) = val - scan;
18655     }
18656 }
18657
18658 #ifdef DEBUGGING
18659 /*
18660 - regtail_study - set the next-pointer at the end of a node chain of p to val.
18661 - Look for optimizable sequences at the same time.
18662 - currently only looks for EXACT chains.
18663
18664 This is experimental code. The idea is to use this routine to perform
18665 in place optimizations on branches and groups as they are constructed,
18666 with the long term intention of removing optimization from study_chunk so
18667 that it is purely analytical.
18668
18669 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
18670 to control which is which.
18671
18672 */
18673 /* TODO: All four parms should be const */
18674
18675 STATIC U8
18676 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
18677                       const regnode *val,U32 depth)
18678 {
18679     regnode *scan;
18680     U8 exact = PSEUDO;
18681 #ifdef EXPERIMENTAL_INPLACESCAN
18682     I32 min = 0;
18683 #endif
18684     GET_RE_DEBUG_FLAGS_DECL;
18685
18686     PERL_ARGS_ASSERT_REGTAIL_STUDY;
18687
18688
18689     if (SIZE_ONLY)
18690         return exact;
18691
18692     /* Find last node. */
18693
18694     scan = p;
18695     for (;;) {
18696         regnode * const temp = regnext(scan);
18697 #ifdef EXPERIMENTAL_INPLACESCAN
18698         if (PL_regkind[OP(scan)] == EXACT) {
18699             bool unfolded_multi_char;   /* Unexamined in this routine */
18700             if (join_exact(pRExC_state, scan, &min,
18701                            &unfolded_multi_char, 1, val, depth+1))
18702                 return EXACT;
18703         }
18704 #endif
18705         if ( exact ) {
18706             switch (OP(scan)) {
18707                 case EXACT:
18708                 case EXACTL:
18709                 case EXACTF:
18710                 case EXACTFA_NO_TRIE:
18711                 case EXACTFA:
18712                 case EXACTFU:
18713                 case EXACTFLU8:
18714                 case EXACTFU_SS:
18715                 case EXACTFL:
18716                         if( exact == PSEUDO )
18717                             exact= OP(scan);
18718                         else if ( exact != OP(scan) )
18719                             exact= 0;
18720                 case NOTHING:
18721                     break;
18722                 default:
18723                     exact= 0;
18724             }
18725         }
18726         DEBUG_PARSE_r({
18727             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
18728             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18729             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
18730                 SvPV_nolen_const(RExC_mysv),
18731                 REG_NODE_NUM(scan),
18732                 PL_reg_name[exact]);
18733         });
18734         if (temp == NULL)
18735             break;
18736         scan = temp;
18737     }
18738     DEBUG_PARSE_r({
18739         DEBUG_PARSE_MSG("");
18740         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
18741         Perl_re_printf( aTHX_
18742                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
18743                       SvPV_nolen_const(RExC_mysv),
18744                       (IV)REG_NODE_NUM(val),
18745                       (IV)(val - scan)
18746         );
18747     });
18748     if (reg_off_by_arg[OP(scan)]) {
18749         ARG_SET(scan, val - scan);
18750     }
18751     else {
18752         NEXT_OFF(scan) = val - scan;
18753     }
18754
18755     return exact;
18756 }
18757 #endif
18758
18759 /*
18760  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
18761  */
18762 #ifdef DEBUGGING
18763
18764 static void
18765 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
18766 {
18767     int bit;
18768     int set=0;
18769
18770     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18771
18772     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
18773         if (flags & (1<<bit)) {
18774             if (!set++ && lead)
18775                 Perl_re_printf( aTHX_  "%s",lead);
18776             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
18777         }
18778     }
18779     if (lead)  {
18780         if (set)
18781             Perl_re_printf( aTHX_  "\n");
18782         else
18783             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18784     }
18785 }
18786
18787 static void
18788 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
18789 {
18790     int bit;
18791     int set=0;
18792     regex_charset cs;
18793
18794     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18795
18796     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
18797         if (flags & (1<<bit)) {
18798             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
18799                 continue;
18800             }
18801             if (!set++ && lead)
18802                 Perl_re_printf( aTHX_  "%s",lead);
18803             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
18804         }
18805     }
18806     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
18807             if (!set++ && lead) {
18808                 Perl_re_printf( aTHX_  "%s",lead);
18809             }
18810             switch (cs) {
18811                 case REGEX_UNICODE_CHARSET:
18812                     Perl_re_printf( aTHX_  "UNICODE");
18813                     break;
18814                 case REGEX_LOCALE_CHARSET:
18815                     Perl_re_printf( aTHX_  "LOCALE");
18816                     break;
18817                 case REGEX_ASCII_RESTRICTED_CHARSET:
18818                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
18819                     break;
18820                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
18821                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
18822                     break;
18823                 default:
18824                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
18825                     break;
18826             }
18827     }
18828     if (lead)  {
18829         if (set)
18830             Perl_re_printf( aTHX_  "\n");
18831         else
18832             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18833     }
18834 }
18835 #endif
18836
18837 void
18838 Perl_regdump(pTHX_ const regexp *r)
18839 {
18840 #ifdef DEBUGGING
18841     SV * const sv = sv_newmortal();
18842     SV *dsv= sv_newmortal();
18843     RXi_GET_DECL(r,ri);
18844     GET_RE_DEBUG_FLAGS_DECL;
18845
18846     PERL_ARGS_ASSERT_REGDUMP;
18847
18848     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
18849
18850     /* Header fields of interest. */
18851     if (r->anchored_substr) {
18852         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
18853             RE_SV_DUMPLEN(r->anchored_substr), 30);
18854         Perl_re_printf( aTHX_
18855                       "anchored %s%s at %" IVdf " ",
18856                       s, RE_SV_TAIL(r->anchored_substr),
18857                       (IV)r->anchored_offset);
18858     } else if (r->anchored_utf8) {
18859         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
18860             RE_SV_DUMPLEN(r->anchored_utf8), 30);
18861         Perl_re_printf( aTHX_
18862                       "anchored utf8 %s%s at %" IVdf " ",
18863                       s, RE_SV_TAIL(r->anchored_utf8),
18864                       (IV)r->anchored_offset);
18865     }
18866     if (r->float_substr) {
18867         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
18868             RE_SV_DUMPLEN(r->float_substr), 30);
18869         Perl_re_printf( aTHX_
18870                       "floating %s%s at %" IVdf "..%" UVuf " ",
18871                       s, RE_SV_TAIL(r->float_substr),
18872                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18873     } else if (r->float_utf8) {
18874         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
18875             RE_SV_DUMPLEN(r->float_utf8), 30);
18876         Perl_re_printf( aTHX_
18877                       "floating utf8 %s%s at %" IVdf "..%" UVuf " ",
18878                       s, RE_SV_TAIL(r->float_utf8),
18879                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18880     }
18881     if (r->check_substr || r->check_utf8)
18882         Perl_re_printf( aTHX_
18883                       (const char *)
18884                       (r->check_substr == r->float_substr
18885                        && r->check_utf8 == r->float_utf8
18886                        ? "(checking floating" : "(checking anchored"));
18887     if (r->intflags & PREGf_NOSCAN)
18888         Perl_re_printf( aTHX_  " noscan");
18889     if (r->extflags & RXf_CHECK_ALL)
18890         Perl_re_printf( aTHX_  " isall");
18891     if (r->check_substr || r->check_utf8)
18892         Perl_re_printf( aTHX_  ") ");
18893
18894     if (ri->regstclass) {
18895         regprop(r, sv, ri->regstclass, NULL, NULL);
18896         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
18897     }
18898     if (r->intflags & PREGf_ANCH) {
18899         Perl_re_printf( aTHX_  "anchored");
18900         if (r->intflags & PREGf_ANCH_MBOL)
18901             Perl_re_printf( aTHX_  "(MBOL)");
18902         if (r->intflags & PREGf_ANCH_SBOL)
18903             Perl_re_printf( aTHX_  "(SBOL)");
18904         if (r->intflags & PREGf_ANCH_GPOS)
18905             Perl_re_printf( aTHX_  "(GPOS)");
18906         Perl_re_printf( aTHX_ " ");
18907     }
18908     if (r->intflags & PREGf_GPOS_SEEN)
18909         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
18910     if (r->intflags & PREGf_SKIP)
18911         Perl_re_printf( aTHX_  "plus ");
18912     if (r->intflags & PREGf_IMPLICIT)
18913         Perl_re_printf( aTHX_  "implicit ");
18914     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
18915     if (r->extflags & RXf_EVAL_SEEN)
18916         Perl_re_printf( aTHX_  "with eval ");
18917     Perl_re_printf( aTHX_  "\n");
18918     DEBUG_FLAGS_r({
18919         regdump_extflags("r->extflags: ",r->extflags);
18920         regdump_intflags("r->intflags: ",r->intflags);
18921     });
18922 #else
18923     PERL_ARGS_ASSERT_REGDUMP;
18924     PERL_UNUSED_CONTEXT;
18925     PERL_UNUSED_ARG(r);
18926 #endif  /* DEBUGGING */
18927 }
18928
18929 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
18930 #ifdef DEBUGGING
18931
18932 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
18933      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
18934      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
18935      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
18936      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
18937      || _CC_VERTSPACE != 15
18938 #   error Need to adjust order of anyofs[]
18939 #  endif
18940 static const char * const anyofs[] = {
18941     "\\w",
18942     "\\W",
18943     "\\d",
18944     "\\D",
18945     "[:alpha:]",
18946     "[:^alpha:]",
18947     "[:lower:]",
18948     "[:^lower:]",
18949     "[:upper:]",
18950     "[:^upper:]",
18951     "[:punct:]",
18952     "[:^punct:]",
18953     "[:print:]",
18954     "[:^print:]",
18955     "[:alnum:]",
18956     "[:^alnum:]",
18957     "[:graph:]",
18958     "[:^graph:]",
18959     "[:cased:]",
18960     "[:^cased:]",
18961     "\\s",
18962     "\\S",
18963     "[:blank:]",
18964     "[:^blank:]",
18965     "[:xdigit:]",
18966     "[:^xdigit:]",
18967     "[:cntrl:]",
18968     "[:^cntrl:]",
18969     "[:ascii:]",
18970     "[:^ascii:]",
18971     "\\v",
18972     "\\V"
18973 };
18974 #endif
18975
18976 /*
18977 - regprop - printable representation of opcode, with run time support
18978 */
18979
18980 void
18981 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
18982 {
18983 #ifdef DEBUGGING
18984     int k;
18985     RXi_GET_DECL(prog,progi);
18986     GET_RE_DEBUG_FLAGS_DECL;
18987
18988     PERL_ARGS_ASSERT_REGPROP;
18989
18990     SvPVCLEAR(sv);
18991
18992     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
18993         /* It would be nice to FAIL() here, but this may be called from
18994            regexec.c, and it would be hard to supply pRExC_state. */
18995         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
18996                                               (int)OP(o), (int)REGNODE_MAX);
18997     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
18998
18999     k = PL_regkind[OP(o)];
19000
19001     if (k == EXACT) {
19002         sv_catpvs(sv, " ");
19003         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
19004          * is a crude hack but it may be the best for now since
19005          * we have no flag "this EXACTish node was UTF-8"
19006          * --jhi */
19007         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
19008                   PERL_PV_ESCAPE_UNI_DETECT |
19009                   PERL_PV_ESCAPE_NONASCII   |
19010                   PERL_PV_PRETTY_ELLIPSES   |
19011                   PERL_PV_PRETTY_LTGT       |
19012                   PERL_PV_PRETTY_NOCLEAR
19013                   );
19014     } else if (k == TRIE) {
19015         /* print the details of the trie in dumpuntil instead, as
19016          * progi->data isn't available here */
19017         const char op = OP(o);
19018         const U32 n = ARG(o);
19019         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
19020                (reg_ac_data *)progi->data->data[n] :
19021                NULL;
19022         const reg_trie_data * const trie
19023             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
19024
19025         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
19026         DEBUG_TRIE_COMPILE_r({
19027           if (trie->jump)
19028             sv_catpvs(sv, "(JUMP)");
19029           Perl_sv_catpvf(aTHX_ sv,
19030             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
19031             (UV)trie->startstate,
19032             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
19033             (UV)trie->wordcount,
19034             (UV)trie->minlen,
19035             (UV)trie->maxlen,
19036             (UV)TRIE_CHARCOUNT(trie),
19037             (UV)trie->uniquecharcount
19038           );
19039         });
19040         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
19041             sv_catpvs(sv, "[");
19042             (void) put_charclass_bitmap_innards(sv,
19043                                                 ((IS_ANYOF_TRIE(op))
19044                                                  ? ANYOF_BITMAP(o)
19045                                                  : TRIE_BITMAP(trie)),
19046                                                 NULL,
19047                                                 NULL,
19048                                                 NULL,
19049                                                 FALSE
19050                                                );
19051             sv_catpvs(sv, "]");
19052         }
19053     } else if (k == CURLY) {
19054         U32 lo = ARG1(o), hi = ARG2(o);
19055         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
19056             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
19057         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
19058         if (hi == REG_INFTY)
19059             sv_catpvs(sv, "INFTY");
19060         else
19061             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
19062         sv_catpvs(sv, "}");
19063     }
19064     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
19065         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
19066     else if (k == REF || k == OPEN || k == CLOSE
19067              || k == GROUPP || OP(o)==ACCEPT)
19068     {
19069         AV *name_list= NULL;
19070         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
19071         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
19072         if ( RXp_PAREN_NAMES(prog) ) {
19073             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19074         } else if ( pRExC_state ) {
19075             name_list= RExC_paren_name_list;
19076         }
19077         if (name_list) {
19078             if ( k != REF || (OP(o) < NREF)) {
19079                 SV **name= av_fetch(name_list, parno, 0 );
19080                 if (name)
19081                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19082             }
19083             else {
19084                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
19085                 I32 *nums=(I32*)SvPVX(sv_dat);
19086                 SV **name= av_fetch(name_list, nums[0], 0 );
19087                 I32 n;
19088                 if (name) {
19089                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
19090                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
19091                                     (n ? "," : ""), (IV)nums[n]);
19092                     }
19093                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19094                 }
19095             }
19096         }
19097         if ( k == REF && reginfo) {
19098             U32 n = ARG(o);  /* which paren pair */
19099             I32 ln = prog->offs[n].start;
19100             if (prog->lastparen < n || ln == -1)
19101                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
19102             else if (ln == prog->offs[n].end)
19103                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
19104             else {
19105                 const char *s = reginfo->strbeg + ln;
19106                 Perl_sv_catpvf(aTHX_ sv, ": ");
19107                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
19108                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
19109             }
19110         }
19111     } else if (k == GOSUB) {
19112         AV *name_list= NULL;
19113         if ( RXp_PAREN_NAMES(prog) ) {
19114             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19115         } else if ( pRExC_state ) {
19116             name_list= RExC_paren_name_list;
19117         }
19118
19119         /* Paren and offset */
19120         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
19121                 (int)((o + (int)ARG2L(o)) - progi->program) );
19122         if (name_list) {
19123             SV **name= av_fetch(name_list, ARG(o), 0 );
19124             if (name)
19125                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19126         }
19127     }
19128     else if (k == LOGICAL)
19129         /* 2: embedded, otherwise 1 */
19130         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
19131     else if (k == ANYOF) {
19132         const U8 flags = ANYOF_FLAGS(o);
19133         bool do_sep = FALSE;    /* Do we need to separate various components of
19134                                    the output? */
19135         /* Set if there is still an unresolved user-defined property */
19136         SV *unresolved                = NULL;
19137
19138         /* Things that are ignored except when the runtime locale is UTF-8 */
19139         SV *only_utf8_locale_invlist = NULL;
19140
19141         /* Code points that don't fit in the bitmap */
19142         SV *nonbitmap_invlist = NULL;
19143
19144         /* And things that aren't in the bitmap, but are small enough to be */
19145         SV* bitmap_range_not_in_bitmap = NULL;
19146
19147         const bool inverted = flags & ANYOF_INVERT;
19148
19149         if (OP(o) == ANYOFL) {
19150             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
19151                 sv_catpvs(sv, "{utf8-locale-reqd}");
19152             }
19153             if (flags & ANYOFL_FOLD) {
19154                 sv_catpvs(sv, "{i}");
19155             }
19156         }
19157
19158         /* If there is stuff outside the bitmap, get it */
19159         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
19160             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
19161                                                 &unresolved,
19162                                                 &only_utf8_locale_invlist,
19163                                                 &nonbitmap_invlist);
19164             /* The non-bitmap data may contain stuff that could fit in the
19165              * bitmap.  This could come from a user-defined property being
19166              * finally resolved when this call was done; or much more likely
19167              * because there are matches that require UTF-8 to be valid, and so
19168              * aren't in the bitmap.  This is teased apart later */
19169             _invlist_intersection(nonbitmap_invlist,
19170                                   PL_InBitmap,
19171                                   &bitmap_range_not_in_bitmap);
19172             /* Leave just the things that don't fit into the bitmap */
19173             _invlist_subtract(nonbitmap_invlist,
19174                               PL_InBitmap,
19175                               &nonbitmap_invlist);
19176         }
19177
19178         /* Obey this flag to add all above-the-bitmap code points */
19179         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
19180             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
19181                                                       NUM_ANYOF_CODE_POINTS,
19182                                                       UV_MAX);
19183         }
19184
19185         /* Ready to start outputting.  First, the initial left bracket */
19186         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19187
19188         /* Then all the things that could fit in the bitmap */
19189         do_sep = put_charclass_bitmap_innards(sv,
19190                                               ANYOF_BITMAP(o),
19191                                               bitmap_range_not_in_bitmap,
19192                                               only_utf8_locale_invlist,
19193                                               o,
19194
19195                                               /* Can't try inverting for a
19196                                                * better display if there are
19197                                                * things that haven't been
19198                                                * resolved */
19199                                               unresolved != NULL);
19200         SvREFCNT_dec(bitmap_range_not_in_bitmap);
19201
19202         /* If there are user-defined properties which haven't been defined yet,
19203          * output them.  If the result is not to be inverted, it is clearest to
19204          * output them in a separate [] from the bitmap range stuff.  If the
19205          * result is to be complemented, we have to show everything in one [],
19206          * as the inversion applies to the whole thing.  Use {braces} to
19207          * separate them from anything in the bitmap and anything above the
19208          * bitmap. */
19209         if (unresolved) {
19210             if (inverted) {
19211                 if (! do_sep) { /* If didn't output anything in the bitmap */
19212                     sv_catpvs(sv, "^");
19213                 }
19214                 sv_catpvs(sv, "{");
19215             }
19216             else if (do_sep) {
19217                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19218             }
19219             sv_catsv(sv, unresolved);
19220             if (inverted) {
19221                 sv_catpvs(sv, "}");
19222             }
19223             do_sep = ! inverted;
19224         }
19225
19226         /* And, finally, add the above-the-bitmap stuff */
19227         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
19228             SV* contents;
19229
19230             /* See if truncation size is overridden */
19231             const STRLEN dump_len = (PL_dump_re_max_len)
19232                                     ? PL_dump_re_max_len
19233                                     : 256;
19234
19235             /* This is output in a separate [] */
19236             if (do_sep) {
19237                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19238             }
19239
19240             /* And, for easy of understanding, it is shown in the
19241              * uncomplemented form if possible.  The one exception being if
19242              * there are unresolved items, where the inversion has to be
19243              * delayed until runtime */
19244             if (inverted && ! unresolved) {
19245                 _invlist_invert(nonbitmap_invlist);
19246                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
19247             }
19248
19249             contents = invlist_contents(nonbitmap_invlist,
19250                                         FALSE /* output suitable for catsv */
19251                                        );
19252
19253             /* If the output is shorter than the permissible maximum, just do it. */
19254             if (SvCUR(contents) <= dump_len) {
19255                 sv_catsv(sv, contents);
19256             }
19257             else {
19258                 const char * contents_string = SvPVX(contents);
19259                 STRLEN i = dump_len;
19260
19261                 /* Otherwise, start at the permissible max and work back to the
19262                  * first break possibility */
19263                 while (i > 0 && contents_string[i] != ' ') {
19264                     i--;
19265                 }
19266                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
19267                                        find a legal break */
19268                     i = dump_len;
19269                 }
19270
19271                 sv_catpvn(sv, contents_string, i);
19272                 sv_catpvs(sv, "...");
19273             }
19274
19275             SvREFCNT_dec_NN(contents);
19276             SvREFCNT_dec_NN(nonbitmap_invlist);
19277         }
19278
19279         /* And finally the matching, closing ']' */
19280         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19281
19282         SvREFCNT_dec(unresolved);
19283     }
19284     else if (k == POSIXD || k == NPOSIXD) {
19285         U8 index = FLAGS(o) * 2;
19286         if (index < C_ARRAY_LENGTH(anyofs)) {
19287             if (*anyofs[index] != '[')  {
19288                 sv_catpv(sv, "[");
19289             }
19290             sv_catpv(sv, anyofs[index]);
19291             if (*anyofs[index] != '[')  {
19292                 sv_catpv(sv, "]");
19293             }
19294         }
19295         else {
19296             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
19297         }
19298     }
19299     else if (k == BOUND || k == NBOUND) {
19300         /* Must be synced with order of 'bound_type' in regcomp.h */
19301         const char * const bounds[] = {
19302             "",      /* Traditional */
19303             "{gcb}",
19304             "{lb}",
19305             "{sb}",
19306             "{wb}"
19307         };
19308         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
19309         sv_catpv(sv, bounds[FLAGS(o)]);
19310     }
19311     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
19312         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
19313     else if (OP(o) == SBOL)
19314         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
19315
19316     /* add on the verb argument if there is one */
19317     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
19318         Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
19319                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
19320     }
19321 #else
19322     PERL_UNUSED_CONTEXT;
19323     PERL_UNUSED_ARG(sv);
19324     PERL_UNUSED_ARG(o);
19325     PERL_UNUSED_ARG(prog);
19326     PERL_UNUSED_ARG(reginfo);
19327     PERL_UNUSED_ARG(pRExC_state);
19328 #endif  /* DEBUGGING */
19329 }
19330
19331
19332
19333 SV *
19334 Perl_re_intuit_string(pTHX_ REGEXP * const r)
19335 {                               /* Assume that RE_INTUIT is set */
19336     struct regexp *const prog = ReANY(r);
19337     GET_RE_DEBUG_FLAGS_DECL;
19338
19339     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
19340     PERL_UNUSED_CONTEXT;
19341
19342     DEBUG_COMPILE_r(
19343         {
19344             const char * const s = SvPV_nolen_const(RX_UTF8(r)
19345                       ? prog->check_utf8 : prog->check_substr);
19346
19347             if (!PL_colorset) reginitcolors();
19348             Perl_re_printf( aTHX_
19349                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
19350                       PL_colors[4],
19351                       RX_UTF8(r) ? "utf8 " : "",
19352                       PL_colors[5],PL_colors[0],
19353                       s,
19354                       PL_colors[1],
19355                       (strlen(s) > 60 ? "..." : ""));
19356         } );
19357
19358     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
19359     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
19360 }
19361
19362 /*
19363    pregfree()
19364
19365    handles refcounting and freeing the perl core regexp structure. When
19366    it is necessary to actually free the structure the first thing it
19367    does is call the 'free' method of the regexp_engine associated to
19368    the regexp, allowing the handling of the void *pprivate; member
19369    first. (This routine is not overridable by extensions, which is why
19370    the extensions free is called first.)
19371
19372    See regdupe and regdupe_internal if you change anything here.
19373 */
19374 #ifndef PERL_IN_XSUB_RE
19375 void
19376 Perl_pregfree(pTHX_ REGEXP *r)
19377 {
19378     SvREFCNT_dec(r);
19379 }
19380
19381 void
19382 Perl_pregfree2(pTHX_ REGEXP *rx)
19383 {
19384     struct regexp *const r = ReANY(rx);
19385     GET_RE_DEBUG_FLAGS_DECL;
19386
19387     PERL_ARGS_ASSERT_PREGFREE2;
19388
19389     if (r->mother_re) {
19390         ReREFCNT_dec(r->mother_re);
19391     } else {
19392         CALLREGFREE_PVT(rx); /* free the private data */
19393         SvREFCNT_dec(RXp_PAREN_NAMES(r));
19394         Safefree(r->xpv_len_u.xpvlenu_pv);
19395     }
19396     if (r->substrs) {
19397         SvREFCNT_dec(r->anchored_substr);
19398         SvREFCNT_dec(r->anchored_utf8);
19399         SvREFCNT_dec(r->float_substr);
19400         SvREFCNT_dec(r->float_utf8);
19401         Safefree(r->substrs);
19402     }
19403     RX_MATCH_COPY_FREE(rx);
19404 #ifdef PERL_ANY_COW
19405     SvREFCNT_dec(r->saved_copy);
19406 #endif
19407     Safefree(r->offs);
19408     SvREFCNT_dec(r->qr_anoncv);
19409     if (r->recurse_locinput)
19410         Safefree(r->recurse_locinput);
19411     rx->sv_u.svu_rx = 0;
19412 }
19413
19414 /*  reg_temp_copy()
19415
19416     This is a hacky workaround to the structural issue of match results
19417     being stored in the regexp structure which is in turn stored in
19418     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
19419     could be PL_curpm in multiple contexts, and could require multiple
19420     result sets being associated with the pattern simultaneously, such
19421     as when doing a recursive match with (??{$qr})
19422
19423     The solution is to make a lightweight copy of the regexp structure
19424     when a qr// is returned from the code executed by (??{$qr}) this
19425     lightweight copy doesn't actually own any of its data except for
19426     the starp/end and the actual regexp structure itself.
19427
19428 */
19429
19430
19431 REGEXP *
19432 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
19433 {
19434     struct regexp *ret;
19435     struct regexp *const r = ReANY(rx);
19436     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
19437
19438     PERL_ARGS_ASSERT_REG_TEMP_COPY;
19439
19440     if (!ret_x)
19441         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
19442     else {
19443         SvOK_off((SV *)ret_x);
19444         if (islv) {
19445             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
19446                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
19447                made both spots point to the same regexp body.) */
19448             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
19449             assert(!SvPVX(ret_x));
19450             ret_x->sv_u.svu_rx = temp->sv_any;
19451             temp->sv_any = NULL;
19452             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
19453             SvREFCNT_dec_NN(temp);
19454             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
19455                ing below will not set it. */
19456             SvCUR_set(ret_x, SvCUR(rx));
19457         }
19458     }
19459     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
19460        sv_force_normal(sv) is called.  */
19461     SvFAKE_on(ret_x);
19462     ret = ReANY(ret_x);
19463
19464     SvFLAGS(ret_x) |= SvUTF8(rx);
19465     /* We share the same string buffer as the original regexp, on which we
19466        hold a reference count, incremented when mother_re is set below.
19467        The string pointer is copied here, being part of the regexp struct.
19468      */
19469     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
19470            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
19471     if (r->offs) {
19472         const I32 npar = r->nparens+1;
19473         Newx(ret->offs, npar, regexp_paren_pair);
19474         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19475     }
19476     if (r->substrs) {
19477         Newx(ret->substrs, 1, struct reg_substr_data);
19478         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19479
19480         SvREFCNT_inc_void(ret->anchored_substr);
19481         SvREFCNT_inc_void(ret->anchored_utf8);
19482         SvREFCNT_inc_void(ret->float_substr);
19483         SvREFCNT_inc_void(ret->float_utf8);
19484
19485         /* check_substr and check_utf8, if non-NULL, point to either their
19486            anchored or float namesakes, and don't hold a second reference.  */
19487     }
19488     RX_MATCH_COPIED_off(ret_x);
19489 #ifdef PERL_ANY_COW
19490     ret->saved_copy = NULL;
19491 #endif
19492     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
19493     SvREFCNT_inc_void(ret->qr_anoncv);
19494     if (r->recurse_locinput)
19495         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19496
19497     return ret_x;
19498 }
19499 #endif
19500
19501 /* regfree_internal()
19502
19503    Free the private data in a regexp. This is overloadable by
19504    extensions. Perl takes care of the regexp structure in pregfree(),
19505    this covers the *pprivate pointer which technically perl doesn't
19506    know about, however of course we have to handle the
19507    regexp_internal structure when no extension is in use.
19508
19509    Note this is called before freeing anything in the regexp
19510    structure.
19511  */
19512
19513 void
19514 Perl_regfree_internal(pTHX_ REGEXP * const rx)
19515 {
19516     struct regexp *const r = ReANY(rx);
19517     RXi_GET_DECL(r,ri);
19518     GET_RE_DEBUG_FLAGS_DECL;
19519
19520     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
19521
19522     DEBUG_COMPILE_r({
19523         if (!PL_colorset)
19524             reginitcolors();
19525         {
19526             SV *dsv= sv_newmortal();
19527             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
19528                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
19529             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
19530                 PL_colors[4],PL_colors[5],s);
19531         }
19532     });
19533 #ifdef RE_TRACK_PATTERN_OFFSETS
19534     if (ri->u.offsets)
19535         Safefree(ri->u.offsets);             /* 20010421 MJD */
19536 #endif
19537     if (ri->code_blocks)
19538         S_free_codeblocks(aTHX_ ri->code_blocks);
19539
19540     if (ri->data) {
19541         int n = ri->data->count;
19542
19543         while (--n >= 0) {
19544           /* If you add a ->what type here, update the comment in regcomp.h */
19545             switch (ri->data->what[n]) {
19546             case 'a':
19547             case 'r':
19548             case 's':
19549             case 'S':
19550             case 'u':
19551                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
19552                 break;
19553             case 'f':
19554                 Safefree(ri->data->data[n]);
19555                 break;
19556             case 'l':
19557             case 'L':
19558                 break;
19559             case 'T':
19560                 { /* Aho Corasick add-on structure for a trie node.
19561                      Used in stclass optimization only */
19562                     U32 refcount;
19563                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
19564 #ifdef USE_ITHREADS
19565                     dVAR;
19566 #endif
19567                     OP_REFCNT_LOCK;
19568                     refcount = --aho->refcount;
19569                     OP_REFCNT_UNLOCK;
19570                     if ( !refcount ) {
19571                         PerlMemShared_free(aho->states);
19572                         PerlMemShared_free(aho->fail);
19573                          /* do this last!!!! */
19574                         PerlMemShared_free(ri->data->data[n]);
19575                         /* we should only ever get called once, so
19576                          * assert as much, and also guard the free
19577                          * which /might/ happen twice. At the least
19578                          * it will make code anlyzers happy and it
19579                          * doesn't cost much. - Yves */
19580                         assert(ri->regstclass);
19581                         if (ri->regstclass) {
19582                             PerlMemShared_free(ri->regstclass);
19583                             ri->regstclass = 0;
19584                         }
19585                     }
19586                 }
19587                 break;
19588             case 't':
19589                 {
19590                     /* trie structure. */
19591                     U32 refcount;
19592                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
19593 #ifdef USE_ITHREADS
19594                     dVAR;
19595 #endif
19596                     OP_REFCNT_LOCK;
19597                     refcount = --trie->refcount;
19598                     OP_REFCNT_UNLOCK;
19599                     if ( !refcount ) {
19600                         PerlMemShared_free(trie->charmap);
19601                         PerlMemShared_free(trie->states);
19602                         PerlMemShared_free(trie->trans);
19603                         if (trie->bitmap)
19604                             PerlMemShared_free(trie->bitmap);
19605                         if (trie->jump)
19606                             PerlMemShared_free(trie->jump);
19607                         PerlMemShared_free(trie->wordinfo);
19608                         /* do this last!!!! */
19609                         PerlMemShared_free(ri->data->data[n]);
19610                     }
19611                 }
19612                 break;
19613             default:
19614                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
19615                                                     ri->data->what[n]);
19616             }
19617         }
19618         Safefree(ri->data->what);
19619         Safefree(ri->data);
19620     }
19621
19622     Safefree(ri);
19623 }
19624
19625 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
19626 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
19627 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
19628
19629 /*
19630    re_dup_guts - duplicate a regexp.
19631
19632    This routine is expected to clone a given regexp structure. It is only
19633    compiled under USE_ITHREADS.
19634
19635    After all of the core data stored in struct regexp is duplicated
19636    the regexp_engine.dupe method is used to copy any private data
19637    stored in the *pprivate pointer. This allows extensions to handle
19638    any duplication it needs to do.
19639
19640    See pregfree() and regfree_internal() if you change anything here.
19641 */
19642 #if defined(USE_ITHREADS)
19643 #ifndef PERL_IN_XSUB_RE
19644 void
19645 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
19646 {
19647     dVAR;
19648     I32 npar;
19649     const struct regexp *r = ReANY(sstr);
19650     struct regexp *ret = ReANY(dstr);
19651
19652     PERL_ARGS_ASSERT_RE_DUP_GUTS;
19653
19654     npar = r->nparens+1;
19655     Newx(ret->offs, npar, regexp_paren_pair);
19656     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19657
19658     if (ret->substrs) {
19659         /* Do it this way to avoid reading from *r after the StructCopy().
19660            That way, if any of the sv_dup_inc()s dislodge *r from the L1
19661            cache, it doesn't matter.  */
19662         const bool anchored = r->check_substr
19663             ? r->check_substr == r->anchored_substr
19664             : r->check_utf8 == r->anchored_utf8;
19665         Newx(ret->substrs, 1, struct reg_substr_data);
19666         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19667
19668         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
19669         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
19670         ret->float_substr = sv_dup_inc(ret->float_substr, param);
19671         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
19672
19673         /* check_substr and check_utf8, if non-NULL, point to either their
19674            anchored or float namesakes, and don't hold a second reference.  */
19675
19676         if (ret->check_substr) {
19677             if (anchored) {
19678                 assert(r->check_utf8 == r->anchored_utf8);
19679                 ret->check_substr = ret->anchored_substr;
19680                 ret->check_utf8 = ret->anchored_utf8;
19681             } else {
19682                 assert(r->check_substr == r->float_substr);
19683                 assert(r->check_utf8 == r->float_utf8);
19684                 ret->check_substr = ret->float_substr;
19685                 ret->check_utf8 = ret->float_utf8;
19686             }
19687         } else if (ret->check_utf8) {
19688             if (anchored) {
19689                 ret->check_utf8 = ret->anchored_utf8;
19690             } else {
19691                 ret->check_utf8 = ret->float_utf8;
19692             }
19693         }
19694     }
19695
19696     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
19697     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
19698     if (r->recurse_locinput)
19699         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19700
19701     if (ret->pprivate)
19702         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
19703
19704     if (RX_MATCH_COPIED(dstr))
19705         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
19706     else
19707         ret->subbeg = NULL;
19708 #ifdef PERL_ANY_COW
19709     ret->saved_copy = NULL;
19710 #endif
19711
19712     /* Whether mother_re be set or no, we need to copy the string.  We
19713        cannot refrain from copying it when the storage points directly to
19714        our mother regexp, because that's
19715                1: a buffer in a different thread
19716                2: something we no longer hold a reference on
19717                so we need to copy it locally.  */
19718     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
19719     ret->mother_re   = NULL;
19720 }
19721 #endif /* PERL_IN_XSUB_RE */
19722
19723 /*
19724    regdupe_internal()
19725
19726    This is the internal complement to regdupe() which is used to copy
19727    the structure pointed to by the *pprivate pointer in the regexp.
19728    This is the core version of the extension overridable cloning hook.
19729    The regexp structure being duplicated will be copied by perl prior
19730    to this and will be provided as the regexp *r argument, however
19731    with the /old/ structures pprivate pointer value. Thus this routine
19732    may override any copying normally done by perl.
19733
19734    It returns a pointer to the new regexp_internal structure.
19735 */
19736
19737 void *
19738 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
19739 {
19740     dVAR;
19741     struct regexp *const r = ReANY(rx);
19742     regexp_internal *reti;
19743     int len;
19744     RXi_GET_DECL(r,ri);
19745
19746     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
19747
19748     len = ProgLen(ri);
19749
19750     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
19751           char, regexp_internal);
19752     Copy(ri->program, reti->program, len+1, regnode);
19753
19754
19755     if (ri->code_blocks) {
19756         int n;
19757         Newx(reti->code_blocks, 1, struct reg_code_blocks);
19758         Newx(reti->code_blocks->cb, ri->code_blocks->count,
19759                     struct reg_code_block);
19760         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
19761              ri->code_blocks->count, struct reg_code_block);
19762         for (n = 0; n < ri->code_blocks->count; n++)
19763              reti->code_blocks->cb[n].src_regex = (REGEXP*)
19764                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
19765         reti->code_blocks->count = ri->code_blocks->count;
19766         reti->code_blocks->refcnt = 1;
19767     }
19768     else
19769         reti->code_blocks = NULL;
19770
19771     reti->regstclass = NULL;
19772
19773     if (ri->data) {
19774         struct reg_data *d;
19775         const int count = ri->data->count;
19776         int i;
19777
19778         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
19779                 char, struct reg_data);
19780         Newx(d->what, count, U8);
19781
19782         d->count = count;
19783         for (i = 0; i < count; i++) {
19784             d->what[i] = ri->data->what[i];
19785             switch (d->what[i]) {
19786                 /* see also regcomp.h and regfree_internal() */
19787             case 'a': /* actually an AV, but the dup function is identical.  */
19788             case 'r':
19789             case 's':
19790             case 'S':
19791             case 'u': /* actually an HV, but the dup function is identical.  */
19792                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
19793                 break;
19794             case 'f':
19795                 /* This is cheating. */
19796                 Newx(d->data[i], 1, regnode_ssc);
19797                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
19798                 reti->regstclass = (regnode*)d->data[i];
19799                 break;
19800             case 'T':
19801                 /* Trie stclasses are readonly and can thus be shared
19802                  * without duplication. We free the stclass in pregfree
19803                  * when the corresponding reg_ac_data struct is freed.
19804                  */
19805                 reti->regstclass= ri->regstclass;
19806                 /* FALLTHROUGH */
19807             case 't':
19808                 OP_REFCNT_LOCK;
19809                 ((reg_trie_data*)ri->data->data[i])->refcount++;
19810                 OP_REFCNT_UNLOCK;
19811                 /* FALLTHROUGH */
19812             case 'l':
19813             case 'L':
19814                 d->data[i] = ri->data->data[i];
19815                 break;
19816             default:
19817                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
19818                                                            ri->data->what[i]);
19819             }
19820         }
19821
19822         reti->data = d;
19823     }
19824     else
19825         reti->data = NULL;
19826
19827     reti->name_list_idx = ri->name_list_idx;
19828
19829 #ifdef RE_TRACK_PATTERN_OFFSETS
19830     if (ri->u.offsets) {
19831         Newx(reti->u.offsets, 2*len+1, U32);
19832         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
19833     }
19834 #else
19835     SetProgLen(reti,len);
19836 #endif
19837
19838     return (void*)reti;
19839 }
19840
19841 #endif    /* USE_ITHREADS */
19842
19843 #ifndef PERL_IN_XSUB_RE
19844
19845 /*
19846  - regnext - dig the "next" pointer out of a node
19847  */
19848 regnode *
19849 Perl_regnext(pTHX_ regnode *p)
19850 {
19851     I32 offset;
19852
19853     if (!p)
19854         return(NULL);
19855
19856     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
19857         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19858                                                 (int)OP(p), (int)REGNODE_MAX);
19859     }
19860
19861     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
19862     if (offset == 0)
19863         return(NULL);
19864
19865     return(p+offset);
19866 }
19867 #endif
19868
19869 STATIC void
19870 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
19871 {
19872     va_list args;
19873     STRLEN l1 = strlen(pat1);
19874     STRLEN l2 = strlen(pat2);
19875     char buf[512];
19876     SV *msv;
19877     const char *message;
19878
19879     PERL_ARGS_ASSERT_RE_CROAK2;
19880
19881     if (l1 > 510)
19882         l1 = 510;
19883     if (l1 + l2 > 510)
19884         l2 = 510 - l1;
19885     Copy(pat1, buf, l1 , char);
19886     Copy(pat2, buf + l1, l2 , char);
19887     buf[l1 + l2] = '\n';
19888     buf[l1 + l2 + 1] = '\0';
19889     va_start(args, pat2);
19890     msv = vmess(buf, &args);
19891     va_end(args);
19892     message = SvPV_const(msv,l1);
19893     if (l1 > 512)
19894         l1 = 512;
19895     Copy(message, buf, l1 , char);
19896     /* l1-1 to avoid \n */
19897     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
19898 }
19899
19900 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
19901
19902 #ifndef PERL_IN_XSUB_RE
19903 void
19904 Perl_save_re_context(pTHX)
19905 {
19906     I32 nparens = -1;
19907     I32 i;
19908
19909     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
19910
19911     if (PL_curpm) {
19912         const REGEXP * const rx = PM_GETRE(PL_curpm);
19913         if (rx)
19914             nparens = RX_NPARENS(rx);
19915     }
19916
19917     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
19918      * that PL_curpm will be null, but that utf8.pm and the modules it
19919      * loads will only use $1..$3.
19920      * The t/porting/re_context.t test file checks this assumption.
19921      */
19922     if (nparens == -1)
19923         nparens = 3;
19924
19925     for (i = 1; i <= nparens; i++) {
19926         char digits[TYPE_CHARS(long)];
19927         const STRLEN len = my_snprintf(digits, sizeof(digits),
19928                                        "%lu", (long)i);
19929         GV *const *const gvp
19930             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
19931
19932         if (gvp) {
19933             GV * const gv = *gvp;
19934             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
19935                 save_scalar(gv);
19936         }
19937     }
19938 }
19939 #endif
19940
19941 #ifdef DEBUGGING
19942
19943 STATIC void
19944 S_put_code_point(pTHX_ SV *sv, UV c)
19945 {
19946     PERL_ARGS_ASSERT_PUT_CODE_POINT;
19947
19948     if (c > 255) {
19949         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
19950     }
19951     else if (isPRINT(c)) {
19952         const char string = (char) c;
19953
19954         /* We use {phrase} as metanotation in the class, so also escape literal
19955          * braces */
19956         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
19957             sv_catpvs(sv, "\\");
19958         sv_catpvn(sv, &string, 1);
19959     }
19960     else if (isMNEMONIC_CNTRL(c)) {
19961         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
19962     }
19963     else {
19964         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
19965     }
19966 }
19967
19968 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
19969
19970 STATIC void
19971 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
19972 {
19973     /* Appends to 'sv' a displayable version of the range of code points from
19974      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
19975      * that have them, when they occur at the beginning or end of the range.
19976      * It uses hex to output the remaining code points, unless 'allow_literals'
19977      * is true, in which case the printable ASCII ones are output as-is (though
19978      * some of these will be escaped by put_code_point()).
19979      *
19980      * NOTE:  This is designed only for printing ranges of code points that fit
19981      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
19982      */
19983
19984     const unsigned int min_range_count = 3;
19985
19986     assert(start <= end);
19987
19988     PERL_ARGS_ASSERT_PUT_RANGE;
19989
19990     while (start <= end) {
19991         UV this_end;
19992         const char * format;
19993
19994         if (end - start < min_range_count) {
19995
19996             /* Output chars individually when they occur in short ranges */
19997             for (; start <= end; start++) {
19998                 put_code_point(sv, start);
19999             }
20000             break;
20001         }
20002
20003         /* If permitted by the input options, and there is a possibility that
20004          * this range contains a printable literal, look to see if there is
20005          * one. */
20006         if (allow_literals && start <= MAX_PRINT_A) {
20007
20008             /* If the character at the beginning of the range isn't an ASCII
20009              * printable, effectively split the range into two parts:
20010              *  1) the portion before the first such printable,
20011              *  2) the rest
20012              * and output them separately. */
20013             if (! isPRINT_A(start)) {
20014                 UV temp_end = start + 1;
20015
20016                 /* There is no point looking beyond the final possible
20017                  * printable, in MAX_PRINT_A */
20018                 UV max = MIN(end, MAX_PRINT_A);
20019
20020                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
20021                     temp_end++;
20022                 }
20023
20024                 /* Here, temp_end points to one beyond the first printable if
20025                  * found, or to one beyond 'max' if not.  If none found, make
20026                  * sure that we use the entire range */
20027                 if (temp_end > MAX_PRINT_A) {
20028                     temp_end = end + 1;
20029                 }
20030
20031                 /* Output the first part of the split range: the part that
20032                  * doesn't have printables, with the parameter set to not look
20033                  * for literals (otherwise we would infinitely recurse) */
20034                 put_range(sv, start, temp_end - 1, FALSE);
20035
20036                 /* The 2nd part of the range (if any) starts here. */
20037                 start = temp_end;
20038
20039                 /* We do a continue, instead of dropping down, because even if
20040                  * the 2nd part is non-empty, it could be so short that we want
20041                  * to output it as individual characters, as tested for at the
20042                  * top of this loop.  */
20043                 continue;
20044             }
20045
20046             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
20047              * output a sub-range of just the digits or letters, then process
20048              * the remaining portion as usual. */
20049             if (isALPHANUMERIC_A(start)) {
20050                 UV mask = (isDIGIT_A(start))
20051                            ? _CC_DIGIT
20052                              : isUPPER_A(start)
20053                                ? _CC_UPPER
20054                                : _CC_LOWER;
20055                 UV temp_end = start + 1;
20056
20057                 /* Find the end of the sub-range that includes just the
20058                  * characters in the same class as the first character in it */
20059                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
20060                     temp_end++;
20061                 }
20062                 temp_end--;
20063
20064                 /* For short ranges, don't duplicate the code above to output
20065                  * them; just call recursively */
20066                 if (temp_end - start < min_range_count) {
20067                     put_range(sv, start, temp_end, FALSE);
20068                 }
20069                 else {  /* Output as a range */
20070                     put_code_point(sv, start);
20071                     sv_catpvs(sv, "-");
20072                     put_code_point(sv, temp_end);
20073                 }
20074                 start = temp_end + 1;
20075                 continue;
20076             }
20077
20078             /* We output any other printables as individual characters */
20079             if (isPUNCT_A(start) || isSPACE_A(start)) {
20080                 while (start <= end && (isPUNCT_A(start)
20081                                         || isSPACE_A(start)))
20082                 {
20083                     put_code_point(sv, start);
20084                     start++;
20085                 }
20086                 continue;
20087             }
20088         } /* End of looking for literals */
20089
20090         /* Here is not to output as a literal.  Some control characters have
20091          * mnemonic names.  Split off any of those at the beginning and end of
20092          * the range to print mnemonically.  It isn't possible for many of
20093          * these to be in a row, so this won't overwhelm with output */
20094         if (   start <= end
20095             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
20096         {
20097             while (isMNEMONIC_CNTRL(start) && start <= end) {
20098                 put_code_point(sv, start);
20099                 start++;
20100             }
20101
20102             /* If this didn't take care of the whole range ... */
20103             if (start <= end) {
20104
20105                 /* Look backwards from the end to find the final non-mnemonic
20106                  * */
20107                 UV temp_end = end;
20108                 while (isMNEMONIC_CNTRL(temp_end)) {
20109                     temp_end--;
20110                 }
20111
20112                 /* And separately output the interior range that doesn't start
20113                  * or end with mnemonics */
20114                 put_range(sv, start, temp_end, FALSE);
20115
20116                 /* Then output the mnemonic trailing controls */
20117                 start = temp_end + 1;
20118                 while (start <= end) {
20119                     put_code_point(sv, start);
20120                     start++;
20121                 }
20122                 break;
20123             }
20124         }
20125
20126         /* As a final resort, output the range or subrange as hex. */
20127
20128         this_end = (end < NUM_ANYOF_CODE_POINTS)
20129                     ? end
20130                     : NUM_ANYOF_CODE_POINTS - 1;
20131 #if NUM_ANYOF_CODE_POINTS > 256
20132         format = (this_end < 256)
20133                  ? "\\x%02" UVXf "-\\x%02" UVXf
20134                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
20135 #else
20136         format = "\\x%02" UVXf "-\\x%02" UVXf;
20137 #endif
20138         GCC_DIAG_IGNORE(-Wformat-nonliteral);
20139         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
20140         GCC_DIAG_RESTORE;
20141         break;
20142     }
20143 }
20144
20145 STATIC void
20146 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
20147 {
20148     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
20149      * 'invlist' */
20150
20151     UV start, end;
20152     bool allow_literals = TRUE;
20153
20154     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
20155
20156     /* Generally, it is more readable if printable characters are output as
20157      * literals, but if a range (nearly) spans all of them, it's best to output
20158      * it as a single range.  This code will use a single range if all but 2
20159      * ASCII printables are in it */
20160     invlist_iterinit(invlist);
20161     while (invlist_iternext(invlist, &start, &end)) {
20162
20163         /* If the range starts beyond the final printable, it doesn't have any
20164          * in it */
20165         if (start > MAX_PRINT_A) {
20166             break;
20167         }
20168
20169         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
20170          * all but two, the range must start and end no later than 2 from
20171          * either end */
20172         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
20173             if (end > MAX_PRINT_A) {
20174                 end = MAX_PRINT_A;
20175             }
20176             if (start < ' ') {
20177                 start = ' ';
20178             }
20179             if (end - start >= MAX_PRINT_A - ' ' - 2) {
20180                 allow_literals = FALSE;
20181             }
20182             break;
20183         }
20184     }
20185     invlist_iterfinish(invlist);
20186
20187     /* Here we have figured things out.  Output each range */
20188     invlist_iterinit(invlist);
20189     while (invlist_iternext(invlist, &start, &end)) {
20190         if (start >= NUM_ANYOF_CODE_POINTS) {
20191             break;
20192         }
20193         put_range(sv, start, end, allow_literals);
20194     }
20195     invlist_iterfinish(invlist);
20196
20197     return;
20198 }
20199
20200 STATIC SV*
20201 S_put_charclass_bitmap_innards_common(pTHX_
20202         SV* invlist,            /* The bitmap */
20203         SV* posixes,            /* Under /l, things like [:word:], \S */
20204         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
20205         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
20206         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
20207         const bool invert       /* Is the result to be inverted? */
20208 )
20209 {
20210     /* Create and return an SV containing a displayable version of the bitmap
20211      * and associated information determined by the input parameters.  If the
20212      * output would have been only the inversion indicator '^', NULL is instead
20213      * returned. */
20214
20215     SV * output;
20216
20217     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
20218
20219     if (invert) {
20220         output = newSVpvs("^");
20221     }
20222     else {
20223         output = newSVpvs("");
20224     }
20225
20226     /* First, the code points in the bitmap that are unconditionally there */
20227     put_charclass_bitmap_innards_invlist(output, invlist);
20228
20229     /* Traditionally, these have been placed after the main code points */
20230     if (posixes) {
20231         sv_catsv(output, posixes);
20232     }
20233
20234     if (only_utf8 && _invlist_len(only_utf8)) {
20235         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
20236         put_charclass_bitmap_innards_invlist(output, only_utf8);
20237     }
20238
20239     if (not_utf8 && _invlist_len(not_utf8)) {
20240         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
20241         put_charclass_bitmap_innards_invlist(output, not_utf8);
20242     }
20243
20244     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
20245         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
20246         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
20247
20248         /* This is the only list in this routine that can legally contain code
20249          * points outside the bitmap range.  The call just above to
20250          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
20251          * output them here.  There's about a half-dozen possible, and none in
20252          * contiguous ranges longer than 2 */
20253         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20254             UV start, end;
20255             SV* above_bitmap = NULL;
20256
20257             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
20258
20259             invlist_iterinit(above_bitmap);
20260             while (invlist_iternext(above_bitmap, &start, &end)) {
20261                 UV i;
20262
20263                 for (i = start; i <= end; i++) {
20264                     put_code_point(output, i);
20265                 }
20266             }
20267             invlist_iterfinish(above_bitmap);
20268             SvREFCNT_dec_NN(above_bitmap);
20269         }
20270     }
20271
20272     if (invert && SvCUR(output) == 1) {
20273         return NULL;
20274     }
20275
20276     return output;
20277 }
20278
20279 STATIC bool
20280 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
20281                                      char *bitmap,
20282                                      SV *nonbitmap_invlist,
20283                                      SV *only_utf8_locale_invlist,
20284                                      const regnode * const node,
20285                                      const bool force_as_is_display)
20286 {
20287     /* Appends to 'sv' a displayable version of the innards of the bracketed
20288      * character class defined by the other arguments:
20289      *  'bitmap' points to the bitmap.
20290      *  'nonbitmap_invlist' is an inversion list of the code points that are in
20291      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
20292      *      none.  The reasons for this could be that they require some
20293      *      condition such as the target string being or not being in UTF-8
20294      *      (under /d), or because they came from a user-defined property that
20295      *      was not resolved at the time of the regex compilation (under /u)
20296      *  'only_utf8_locale_invlist' is an inversion list of the code points that
20297      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
20298      *  'node' is the regex pattern node.  It is needed only when the above two
20299      *      parameters are not null, and is passed so that this routine can
20300      *      tease apart the various reasons for them.
20301      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
20302      *      to invert things to see if that leads to a cleaner display.  If
20303      *      FALSE, this routine is free to use its judgment about doing this.
20304      *
20305      * It returns TRUE if there was actually something output.  (It may be that
20306      * the bitmap, etc is empty.)
20307      *
20308      * When called for outputting the bitmap of a non-ANYOF node, just pass the
20309      * bitmap, with the succeeding parameters set to NULL, and the final one to
20310      * FALSE.
20311      */
20312
20313     /* In general, it tries to display the 'cleanest' representation of the
20314      * innards, choosing whether to display them inverted or not, regardless of
20315      * whether the class itself is to be inverted.  However,  there are some
20316      * cases where it can't try inverting, as what actually matches isn't known
20317      * until runtime, and hence the inversion isn't either. */
20318     bool inverting_allowed = ! force_as_is_display;
20319
20320     int i;
20321     STRLEN orig_sv_cur = SvCUR(sv);
20322
20323     SV* invlist;            /* Inversion list we accumulate of code points that
20324                                are unconditionally matched */
20325     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
20326                                UTF-8 */
20327     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
20328                              */
20329     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
20330     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
20331                                        is UTF-8 */
20332
20333     SV* as_is_display;      /* The output string when we take the inputs
20334                                literally */
20335     SV* inverted_display;   /* The output string when we invert the inputs */
20336
20337     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
20338
20339     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
20340                                                    to match? */
20341     /* We are biased in favor of displaying things without them being inverted,
20342      * as that is generally easier to understand */
20343     const int bias = 5;
20344
20345     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
20346
20347     /* Start off with whatever code points are passed in.  (We clone, so we
20348      * don't change the caller's list) */
20349     if (nonbitmap_invlist) {
20350         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
20351         invlist = invlist_clone(nonbitmap_invlist);
20352     }
20353     else {  /* Worst case size is every other code point is matched */
20354         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
20355     }
20356
20357     if (flags) {
20358         if (OP(node) == ANYOFD) {
20359
20360             /* This flag indicates that the code points below 0x100 in the
20361              * nonbitmap list are precisely the ones that match only when the
20362              * target is UTF-8 (they should all be non-ASCII). */
20363             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
20364             {
20365                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
20366                 _invlist_subtract(invlist, only_utf8, &invlist);
20367             }
20368
20369             /* And this flag for matching all non-ASCII 0xFF and below */
20370             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
20371             {
20372                 not_utf8 = invlist_clone(PL_UpperLatin1);
20373             }
20374         }
20375         else if (OP(node) == ANYOFL) {
20376
20377             /* If either of these flags are set, what matches isn't
20378              * determinable except during execution, so don't know enough here
20379              * to invert */
20380             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
20381                 inverting_allowed = FALSE;
20382             }
20383
20384             /* What the posix classes match also varies at runtime, so these
20385              * will be output symbolically. */
20386             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
20387                 int i;
20388
20389                 posixes = newSVpvs("");
20390                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
20391                     if (ANYOF_POSIXL_TEST(node,i)) {
20392                         sv_catpv(posixes, anyofs[i]);
20393                     }
20394                 }
20395             }
20396         }
20397     }
20398
20399     /* Accumulate the bit map into the unconditional match list */
20400     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
20401         if (BITMAP_TEST(bitmap, i)) {
20402             int start = i++;
20403             for (; i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i); i++) {
20404                 /* empty */
20405             }
20406             invlist = _add_range_to_invlist(invlist, start, i-1);
20407         }
20408     }
20409
20410     /* Make sure that the conditional match lists don't have anything in them
20411      * that match unconditionally; otherwise the output is quite confusing.
20412      * This could happen if the code that populates these misses some
20413      * duplication. */
20414     if (only_utf8) {
20415         _invlist_subtract(only_utf8, invlist, &only_utf8);
20416     }
20417     if (not_utf8) {
20418         _invlist_subtract(not_utf8, invlist, &not_utf8);
20419     }
20420
20421     if (only_utf8_locale_invlist) {
20422
20423         /* Since this list is passed in, we have to make a copy before
20424          * modifying it */
20425         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
20426
20427         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
20428
20429         /* And, it can get really weird for us to try outputting an inverted
20430          * form of this list when it has things above the bitmap, so don't even
20431          * try */
20432         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20433             inverting_allowed = FALSE;
20434         }
20435     }
20436
20437     /* Calculate what the output would be if we take the input as-is */
20438     as_is_display = put_charclass_bitmap_innards_common(invlist,
20439                                                     posixes,
20440                                                     only_utf8,
20441                                                     not_utf8,
20442                                                     only_utf8_locale,
20443                                                     invert);
20444
20445     /* If have to take the output as-is, just do that */
20446     if (! inverting_allowed) {
20447         if (as_is_display) {
20448             sv_catsv(sv, as_is_display);
20449             SvREFCNT_dec_NN(as_is_display);
20450         }
20451     }
20452     else { /* But otherwise, create the output again on the inverted input, and
20453               use whichever version is shorter */
20454
20455         int inverted_bias, as_is_bias;
20456
20457         /* We will apply our bias to whichever of the the results doesn't have
20458          * the '^' */
20459         if (invert) {
20460             invert = FALSE;
20461             as_is_bias = bias;
20462             inverted_bias = 0;
20463         }
20464         else {
20465             invert = TRUE;
20466             as_is_bias = 0;
20467             inverted_bias = bias;
20468         }
20469
20470         /* Now invert each of the lists that contribute to the output,
20471          * excluding from the result things outside the possible range */
20472
20473         /* For the unconditional inversion list, we have to add in all the
20474          * conditional code points, so that when inverted, they will be gone
20475          * from it */
20476         _invlist_union(only_utf8, invlist, &invlist);
20477         _invlist_union(not_utf8, invlist, &invlist);
20478         _invlist_union(only_utf8_locale, invlist, &invlist);
20479         _invlist_invert(invlist);
20480         _invlist_intersection(invlist, PL_InBitmap, &invlist);
20481
20482         if (only_utf8) {
20483             _invlist_invert(only_utf8);
20484             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
20485         }
20486         else if (not_utf8) {
20487
20488             /* If a code point matches iff the target string is not in UTF-8,
20489              * then complementing the result has it not match iff not in UTF-8,
20490              * which is the same thing as matching iff it is UTF-8. */
20491             only_utf8 = not_utf8;
20492             not_utf8 = NULL;
20493         }
20494
20495         if (only_utf8_locale) {
20496             _invlist_invert(only_utf8_locale);
20497             _invlist_intersection(only_utf8_locale,
20498                                   PL_InBitmap,
20499                                   &only_utf8_locale);
20500         }
20501
20502         inverted_display = put_charclass_bitmap_innards_common(
20503                                             invlist,
20504                                             posixes,
20505                                             only_utf8,
20506                                             not_utf8,
20507                                             only_utf8_locale, invert);
20508
20509         /* Use the shortest representation, taking into account our bias
20510          * against showing it inverted */
20511         if (   inverted_display
20512             && (   ! as_is_display
20513                 || (  SvCUR(inverted_display) + inverted_bias
20514                     < SvCUR(as_is_display)    + as_is_bias)))
20515         {
20516             sv_catsv(sv, inverted_display);
20517         }
20518         else if (as_is_display) {
20519             sv_catsv(sv, as_is_display);
20520         }
20521
20522         SvREFCNT_dec(as_is_display);
20523         SvREFCNT_dec(inverted_display);
20524     }
20525
20526     SvREFCNT_dec_NN(invlist);
20527     SvREFCNT_dec(only_utf8);
20528     SvREFCNT_dec(not_utf8);
20529     SvREFCNT_dec(posixes);
20530     SvREFCNT_dec(only_utf8_locale);
20531
20532     return SvCUR(sv) > orig_sv_cur;
20533 }
20534
20535 #define CLEAR_OPTSTART                                                       \
20536     if (optstart) STMT_START {                                               \
20537         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
20538                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
20539         optstart=NULL;                                                       \
20540     } STMT_END
20541
20542 #define DUMPUNTIL(b,e)                                                       \
20543                     CLEAR_OPTSTART;                                          \
20544                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
20545
20546 STATIC const regnode *
20547 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
20548             const regnode *last, const regnode *plast,
20549             SV* sv, I32 indent, U32 depth)
20550 {
20551     U8 op = PSEUDO;     /* Arbitrary non-END op. */
20552     const regnode *next;
20553     const regnode *optstart= NULL;
20554
20555     RXi_GET_DECL(r,ri);
20556     GET_RE_DEBUG_FLAGS_DECL;
20557
20558     PERL_ARGS_ASSERT_DUMPUNTIL;
20559
20560 #ifdef DEBUG_DUMPUNTIL
20561     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
20562         last ? last-start : 0,plast ? plast-start : 0);
20563 #endif
20564
20565     if (plast && plast < last)
20566         last= plast;
20567
20568     while (PL_regkind[op] != END && (!last || node < last)) {
20569         assert(node);
20570         /* While that wasn't END last time... */
20571         NODE_ALIGN(node);
20572         op = OP(node);
20573         if (op == CLOSE || op == WHILEM)
20574             indent--;
20575         next = regnext((regnode *)node);
20576
20577         /* Where, what. */
20578         if (OP(node) == OPTIMIZED) {
20579             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
20580                 optstart = node;
20581             else
20582                 goto after_print;
20583         } else
20584             CLEAR_OPTSTART;
20585
20586         regprop(r, sv, node, NULL, NULL);
20587         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
20588                       (int)(2*indent + 1), "", SvPVX_const(sv));
20589
20590         if (OP(node) != OPTIMIZED) {
20591             if (next == NULL)           /* Next ptr. */
20592                 Perl_re_printf( aTHX_  " (0)");
20593             else if (PL_regkind[(U8)op] == BRANCH
20594                      && PL_regkind[OP(next)] != BRANCH )
20595                 Perl_re_printf( aTHX_  " (FAIL)");
20596             else
20597                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
20598             Perl_re_printf( aTHX_ "\n");
20599         }
20600
20601       after_print:
20602         if (PL_regkind[(U8)op] == BRANCHJ) {
20603             assert(next);
20604             {
20605                 const regnode *nnode = (OP(next) == LONGJMP
20606                                        ? regnext((regnode *)next)
20607                                        : next);
20608                 if (last && nnode > last)
20609                     nnode = last;
20610                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
20611             }
20612         }
20613         else if (PL_regkind[(U8)op] == BRANCH) {
20614             assert(next);
20615             DUMPUNTIL(NEXTOPER(node), next);
20616         }
20617         else if ( PL_regkind[(U8)op]  == TRIE ) {
20618             const regnode *this_trie = node;
20619             const char op = OP(node);
20620             const U32 n = ARG(node);
20621             const reg_ac_data * const ac = op>=AHOCORASICK ?
20622                (reg_ac_data *)ri->data->data[n] :
20623                NULL;
20624             const reg_trie_data * const trie =
20625                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
20626 #ifdef DEBUGGING
20627             AV *const trie_words
20628                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
20629 #endif
20630             const regnode *nextbranch= NULL;
20631             I32 word_idx;
20632             SvPVCLEAR(sv);
20633             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
20634                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
20635
20636                 Perl_re_indentf( aTHX_  "%s ",
20637                     indent+3,
20638                     elem_ptr
20639                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
20640                                 SvCUR(*elem_ptr), 60,
20641                                 PL_colors[0], PL_colors[1],
20642                                 (SvUTF8(*elem_ptr)
20643                                  ? PERL_PV_ESCAPE_UNI
20644                                  : 0)
20645                                 | PERL_PV_PRETTY_ELLIPSES
20646                                 | PERL_PV_PRETTY_LTGT
20647                             )
20648                     : "???"
20649                 );
20650                 if (trie->jump) {
20651                     U16 dist= trie->jump[word_idx+1];
20652                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
20653                                (UV)((dist ? this_trie + dist : next) - start));
20654                     if (dist) {
20655                         if (!nextbranch)
20656                             nextbranch= this_trie + trie->jump[0];
20657                         DUMPUNTIL(this_trie + dist, nextbranch);
20658                     }
20659                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
20660                         nextbranch= regnext((regnode *)nextbranch);
20661                 } else {
20662                     Perl_re_printf( aTHX_  "\n");
20663                 }
20664             }
20665             if (last && next > last)
20666                 node= last;
20667             else
20668                 node= next;
20669         }
20670         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
20671             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
20672                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
20673         }
20674         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
20675             assert(next);
20676             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
20677         }
20678         else if ( op == PLUS || op == STAR) {
20679             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
20680         }
20681         else if (PL_regkind[(U8)op] == ANYOF) {
20682             /* arglen 1 + class block */
20683             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
20684                           ? ANYOF_POSIXL_SKIP
20685                           : ANYOF_SKIP);
20686             node = NEXTOPER(node);
20687         }
20688         else if (PL_regkind[(U8)op] == EXACT) {
20689             /* Literal string, where present. */
20690             node += NODE_SZ_STR(node) - 1;
20691             node = NEXTOPER(node);
20692         }
20693         else {
20694             node = NEXTOPER(node);
20695             node += regarglen[(U8)op];
20696         }
20697         if (op == CURLYX || op == OPEN)
20698             indent++;
20699     }
20700     CLEAR_OPTSTART;
20701 #ifdef DEBUG_DUMPUNTIL
20702     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
20703 #endif
20704     return node;
20705 }
20706
20707 #endif  /* DEBUGGING */
20708
20709 /*
20710  * ex: set ts=8 sts=4 sw=4 et:
20711  */