This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change name of PL_ variable
[perl5.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #  include "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 EXTERN_C const struct regexp_engine my_reg_engine;
85 #else
86 #  include "regcomp.h"
87 #endif
88
89 #include "dquote_inline.h"
90 #include "invlist_inline.h"
91 #include "unicode_constants.h"
92
93 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
94  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
96  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
97 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
98 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
99
100 #ifndef STATIC
101 #define STATIC  static
102 #endif
103
104 /* this is a chain of data about sub patterns we are processing that
105    need to be handled separately/specially in study_chunk. Its so
106    we can simulate recursion without losing state.  */
107 struct scan_frame;
108 typedef struct scan_frame {
109     regnode *last_regnode;      /* last node to process in this frame */
110     regnode *next_regnode;      /* next node to process when last is reached */
111     U32 prev_recursed_depth;
112     I32 stopparen;              /* what stopparen do we use */
113     U32 is_top_frame;           /* what flags do we use? */
114
115     struct scan_frame *this_prev_frame; /* this previous frame */
116     struct scan_frame *prev_frame;      /* previous frame */
117     struct scan_frame *next_frame;      /* next frame */
118 } scan_frame;
119
120 /* Certain characters are output as a sequence with the first being a
121  * backslash. */
122 #define isBACKSLASHED_PUNCT(c)                                              \
123                     ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
124
125
126 struct RExC_state_t {
127     U32         flags;                  /* RXf_* are we folding, multilining? */
128     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
129     char        *precomp;               /* uncompiled string. */
130     char        *precomp_end;           /* pointer to end of uncompiled string. */
131     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
132     regexp      *rx;                    /* perl core regexp structure */
133     regexp_internal     *rxi;           /* internal data for regexp object
134                                            pprivate field */
135     char        *start;                 /* Start of input for compile */
136     char        *end;                   /* End of input for compile */
137     char        *parse;                 /* Input-scan pointer. */
138     char        *adjusted_start;        /* 'start', adjusted.  See code use */
139     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
140     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
141     regnode     *emit_start;            /* Start of emitted-code area */
142     regnode     *emit_bound;            /* First regnode outside of the
143                                            allocated space */
144     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
145                                            implies compiling, so don't emit */
146     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
147                                            large enough for the largest
148                                            non-EXACTish node, so can use it as
149                                            scratch in pass1 */
150     I32         naughty;                /* How bad is this pattern? */
151     I32         sawback;                /* Did we see \1, ...? */
152     U32         seen;
153     SSize_t     size;                   /* Code size. */
154     I32                npar;            /* Capture buffer count, (OPEN) plus
155                                            one. ("par" 0 is the whole
156                                            pattern)*/
157     I32         nestroot;               /* root parens we are in - used by
158                                            accept */
159     I32         extralen;
160     I32         seen_zerolen;
161     regnode     **open_parens;          /* pointers to open parens */
162     regnode     **close_parens;         /* pointers to close parens */
163     regnode     *end_op;                /* END node in program */
164     I32         utf8;           /* whether the pattern is utf8 or not */
165     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
166                                 /* XXX use this for future optimisation of case
167                                  * where pattern must be upgraded to utf8. */
168     I32         uni_semantics;  /* If a d charset modifier should use unicode
169                                    rules, even if the pattern is not in
170                                    utf8 */
171     HV          *paren_names;           /* Paren names */
172
173     regnode     **recurse;              /* Recurse regops */
174     I32                recurse_count;                /* Number of recurse regops we have generated */
175     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
176                                            through */
177     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
178     I32         in_lookbehind;
179     I32         contains_locale;
180     I32         contains_i;
181     I32         override_recoding;
182 #ifdef EBCDIC
183     I32         recode_x_to_native;
184 #endif
185     I32         in_multi_char_class;
186     struct reg_code_block *code_blocks; /* positions of literal (?{})
187                                             within pattern */
188     int         num_code_blocks;        /* size of code_blocks[] */
189     int         code_index;             /* next code_blocks[] slot */
190     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
191     scan_frame *frame_head;
192     scan_frame *frame_last;
193     U32         frame_count;
194     AV         *warn_text;
195 #ifdef ADD_TO_REGEXEC
196     char        *starttry;              /* -Dr: where regtry was called. */
197 #define RExC_starttry   (pRExC_state->starttry)
198 #endif
199     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
200 #ifdef DEBUGGING
201     const char  *lastparse;
202     I32         lastnum;
203     AV          *paren_name_list;       /* idx -> name */
204     U32         study_chunk_recursed_count;
205     SV          *mysv1;
206     SV          *mysv2;
207 #define RExC_lastparse  (pRExC_state->lastparse)
208 #define RExC_lastnum    (pRExC_state->lastnum)
209 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
210 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
211 #define RExC_mysv       (pRExC_state->mysv1)
212 #define RExC_mysv1      (pRExC_state->mysv1)
213 #define RExC_mysv2      (pRExC_state->mysv2)
214
215 #endif
216     bool        seen_unfolded_sharp_s;
217     bool        strict;
218     bool        study_started;
219 };
220
221 #define RExC_flags      (pRExC_state->flags)
222 #define RExC_pm_flags   (pRExC_state->pm_flags)
223 #define RExC_precomp    (pRExC_state->precomp)
224 #define RExC_precomp_adj (pRExC_state->precomp_adj)
225 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
226 #define RExC_precomp_end (pRExC_state->precomp_end)
227 #define RExC_rx_sv      (pRExC_state->rx_sv)
228 #define RExC_rx         (pRExC_state->rx)
229 #define RExC_rxi        (pRExC_state->rxi)
230 #define RExC_start      (pRExC_state->start)
231 #define RExC_end        (pRExC_state->end)
232 #define RExC_parse      (pRExC_state->parse)
233 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
234
235 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
236  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
237  * something forces the pattern into using /ui rules, the sharp s should be
238  * folded into the sequence 'ss', which takes up more space than previously
239  * calculated.  This means that the sizing pass needs to be restarted.  (The
240  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
241  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
242  * so there is no need to resize [perl #125990]. */
243 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
244
245 #ifdef RE_TRACK_PATTERN_OFFSETS
246 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
247                                                          others */
248 #endif
249 #define RExC_emit       (pRExC_state->emit)
250 #define RExC_emit_dummy (pRExC_state->emit_dummy)
251 #define RExC_emit_start (pRExC_state->emit_start)
252 #define RExC_emit_bound (pRExC_state->emit_bound)
253 #define RExC_sawback    (pRExC_state->sawback)
254 #define RExC_seen       (pRExC_state->seen)
255 #define RExC_size       (pRExC_state->size)
256 #define RExC_maxlen        (pRExC_state->maxlen)
257 #define RExC_npar       (pRExC_state->npar)
258 #define RExC_nestroot   (pRExC_state->nestroot)
259 #define RExC_extralen   (pRExC_state->extralen)
260 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
261 #define RExC_utf8       (pRExC_state->utf8)
262 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
263 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
264 #define RExC_open_parens        (pRExC_state->open_parens)
265 #define RExC_close_parens       (pRExC_state->close_parens)
266 #define RExC_end_op     (pRExC_state->end_op)
267 #define RExC_paren_names        (pRExC_state->paren_names)
268 #define RExC_recurse    (pRExC_state->recurse)
269 #define RExC_recurse_count      (pRExC_state->recurse_count)
270 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
271 #define RExC_study_chunk_recursed_bytes  \
272                                    (pRExC_state->study_chunk_recursed_bytes)
273 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
274 #define RExC_contains_locale    (pRExC_state->contains_locale)
275 #define RExC_contains_i (pRExC_state->contains_i)
276 #define RExC_override_recoding (pRExC_state->override_recoding)
277 #ifdef EBCDIC
278 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
279 #endif
280 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
281 #define RExC_frame_head (pRExC_state->frame_head)
282 #define RExC_frame_last (pRExC_state->frame_last)
283 #define RExC_frame_count (pRExC_state->frame_count)
284 #define RExC_strict (pRExC_state->strict)
285 #define RExC_study_started      (pRExC_state->study_started)
286 #define RExC_warn_text (pRExC_state->warn_text)
287
288 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
289  * a flag to disable back-off on the fixed/floating substrings - if it's
290  * a high complexity pattern we assume the benefit of avoiding a full match
291  * is worth the cost of checking for the substrings even if they rarely help.
292  */
293 #define RExC_naughty    (pRExC_state->naughty)
294 #define TOO_NAUGHTY (10)
295 #define MARK_NAUGHTY(add) \
296     if (RExC_naughty < TOO_NAUGHTY) \
297         RExC_naughty += (add)
298 #define MARK_NAUGHTY_EXP(exp, add) \
299     if (RExC_naughty < TOO_NAUGHTY) \
300         RExC_naughty += RExC_naughty / (exp) + (add)
301
302 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
303 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
304         ((*s) == '{' && regcurly(s)))
305
306 /*
307  * Flags to be passed up and down.
308  */
309 #define WORST           0       /* Worst case. */
310 #define HASWIDTH        0x01    /* Known to match non-null strings. */
311
312 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
313  * character.  (There needs to be a case: in the switch statement in regexec.c
314  * for any node marked SIMPLE.)  Note that this is not the same thing as
315  * REGNODE_SIMPLE */
316 #define SIMPLE          0x02
317 #define SPSTART         0x04    /* Starts with * or + */
318 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
319 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
320 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
321 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
322                                    calcuate sizes as UTF-8 */
323
324 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
325
326 /* whether trie related optimizations are enabled */
327 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
328 #define TRIE_STUDY_OPT
329 #define FULL_TRIE_STUDY
330 #define TRIE_STCLASS
331 #endif
332
333
334
335 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
336 #define PBITVAL(paren) (1 << ((paren) & 7))
337 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
338 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
339 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
340
341 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
342                                      if (!UTF) {                           \
343                                          assert(PASS1);                    \
344                                          *flagp = RESTART_PASS1|NEED_UTF8; \
345                                          return NULL;                      \
346                                      }                                     \
347                              } STMT_END
348
349 /* Change from /d into /u rules, and restart the parse if we've already seen
350  * something whose size would increase as a result, by setting *flagp and
351  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
352  * we've change to /u during the parse.  */
353 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
354     STMT_START {                                                            \
355             if (DEPENDS_SEMANTICS) {                                        \
356                 assert(PASS1);                                              \
357                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
358                 RExC_uni_semantics = 1;                                     \
359                 if (RExC_seen_unfolded_sharp_s) {                           \
360                     *flagp |= RESTART_PASS1;                                \
361                     return restart_retval;                                  \
362                 }                                                           \
363             }                                                               \
364     } STMT_END
365
366 /* This converts the named class defined in regcomp.h to its equivalent class
367  * number defined in handy.h. */
368 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
369 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
370
371 #define _invlist_union_complement_2nd(a, b, output) \
372                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
373 #define _invlist_intersection_complement_2nd(a, b, output) \
374                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
375
376 /* About scan_data_t.
377
378   During optimisation we recurse through the regexp program performing
379   various inplace (keyhole style) optimisations. In addition study_chunk
380   and scan_commit populate this data structure with information about
381   what strings MUST appear in the pattern. We look for the longest
382   string that must appear at a fixed location, and we look for the
383   longest string that may appear at a floating location. So for instance
384   in the pattern:
385
386     /FOO[xX]A.*B[xX]BAR/
387
388   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
389   strings (because they follow a .* construct). study_chunk will identify
390   both FOO and BAR as being the longest fixed and floating strings respectively.
391
392   The strings can be composites, for instance
393
394      /(f)(o)(o)/
395
396   will result in a composite fixed substring 'foo'.
397
398   For each string some basic information is maintained:
399
400   - offset or min_offset
401     This is the position the string must appear at, or not before.
402     It also implicitly (when combined with minlenp) tells us how many
403     characters must match before the string we are searching for.
404     Likewise when combined with minlenp and the length of the string it
405     tells us how many characters must appear after the string we have
406     found.
407
408   - max_offset
409     Only used for floating strings. This is the rightmost point that
410     the string can appear at. If set to SSize_t_MAX it indicates that the
411     string can occur infinitely far to the right.
412
413   - minlenp
414     A pointer to the minimum number of characters of the pattern that the
415     string was found inside. This is important as in the case of positive
416     lookahead or positive lookbehind we can have multiple patterns
417     involved. Consider
418
419     /(?=FOO).*F/
420
421     The minimum length of the pattern overall is 3, the minimum length
422     of the lookahead part is 3, but the minimum length of the part that
423     will actually match is 1. So 'FOO's minimum length is 3, but the
424     minimum length for the F is 1. This is important as the minimum length
425     is used to determine offsets in front of and behind the string being
426     looked for.  Since strings can be composites this is the length of the
427     pattern at the time it was committed with a scan_commit. Note that
428     the length is calculated by study_chunk, so that the minimum lengths
429     are not known until the full pattern has been compiled, thus the
430     pointer to the value.
431
432   - lookbehind
433
434     In the case of lookbehind the string being searched for can be
435     offset past the start point of the final matching string.
436     If this value was just blithely removed from the min_offset it would
437     invalidate some of the calculations for how many chars must match
438     before or after (as they are derived from min_offset and minlen and
439     the length of the string being searched for).
440     When the final pattern is compiled and the data is moved from the
441     scan_data_t structure into the regexp structure the information
442     about lookbehind is factored in, with the information that would
443     have been lost precalculated in the end_shift field for the
444     associated string.
445
446   The fields pos_min and pos_delta are used to store the minimum offset
447   and the delta to the maximum offset at the current point in the pattern.
448
449 */
450
451 typedef struct scan_data_t {
452     /*I32 len_min;      unused */
453     /*I32 len_delta;    unused */
454     SSize_t pos_min;
455     SSize_t pos_delta;
456     SV *last_found;
457     SSize_t last_end;       /* min value, <0 unless valid. */
458     SSize_t last_start_min;
459     SSize_t last_start_max;
460     SV **longest;           /* Either &l_fixed, or &l_float. */
461     SV *longest_fixed;      /* longest fixed string found in pattern */
462     SSize_t offset_fixed;   /* offset where it starts */
463     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
464     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
465     SV *longest_float;      /* longest floating string found in pattern */
466     SSize_t offset_float_min; /* earliest point in string it can appear */
467     SSize_t offset_float_max; /* latest point in string it can appear */
468     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
469     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
470     I32 flags;
471     I32 whilem_c;
472     SSize_t *last_closep;
473     regnode_ssc *start_class;
474 } scan_data_t;
475
476 /*
477  * Forward declarations for pregcomp()'s friends.
478  */
479
480 static const scan_data_t zero_scan_data =
481   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
482
483 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
484 #define SF_BEFORE_SEOL          0x0001
485 #define SF_BEFORE_MEOL          0x0002
486 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
487 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
488
489 #define SF_FIX_SHIFT_EOL        (+2)
490 #define SF_FL_SHIFT_EOL         (+4)
491
492 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
493 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
494
495 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
496 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
497 #define SF_IS_INF               0x0040
498 #define SF_HAS_PAR              0x0080
499 #define SF_IN_PAR               0x0100
500 #define SF_HAS_EVAL             0x0200
501
502
503 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
504  * longest substring in the pattern. When it is not set the optimiser keeps
505  * track of position, but does not keep track of the actual strings seen,
506  *
507  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
508  * /foo/i will not.
509  *
510  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
511  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
512  * turned off because of the alternation (BRANCH). */
513 #define SCF_DO_SUBSTR           0x0400
514
515 #define SCF_DO_STCLASS_AND      0x0800
516 #define SCF_DO_STCLASS_OR       0x1000
517 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
518 #define SCF_WHILEM_VISITED_POS  0x2000
519
520 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
521 #define SCF_SEEN_ACCEPT         0x8000
522 #define SCF_TRIE_DOING_RESTUDY 0x10000
523 #define SCF_IN_DEFINE          0x20000
524
525
526
527
528 #define UTF cBOOL(RExC_utf8)
529
530 /* The enums for all these are ordered so things work out correctly */
531 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
532 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
533                                                      == REGEX_DEPENDS_CHARSET)
534 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
535 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
536                                                      >= REGEX_UNICODE_CHARSET)
537 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
538                                             == REGEX_ASCII_RESTRICTED_CHARSET)
539 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
540                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
541 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
542                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
543
544 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
545
546 /* For programs that want to be strictly Unicode compatible by dying if any
547  * attempt is made to match a non-Unicode code point against a Unicode
548  * property.  */
549 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
550
551 #define OOB_NAMEDCLASS          -1
552
553 /* There is no code point that is out-of-bounds, so this is problematic.  But
554  * its only current use is to initialize a variable that is always set before
555  * looked at. */
556 #define OOB_UNICODE             0xDEADBEEF
557
558 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
559 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
560
561
562 /* length of regex to show in messages that don't mark a position within */
563 #define RegexLengthToShowInErrorMessages 127
564
565 /*
566  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
567  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
568  * op/pragma/warn/regcomp.
569  */
570 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
571 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
572
573 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
574                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
575
576 /* The code in this file in places uses one level of recursion with parsing
577  * rebased to an alternate string constructed by us in memory.  This can take
578  * the form of something that is completely different from the input, or
579  * something that uses the input as part of the alternate.  In the first case,
580  * there should be no possibility of an error, as we are in complete control of
581  * the alternate string.  But in the second case we don't control the input
582  * portion, so there may be errors in that.  Here's an example:
583  *      /[abc\x{DF}def]/ui
584  * is handled specially because \x{df} folds to a sequence of more than one
585  * character, 'ss'.  What is done is to create and parse an alternate string,
586  * which looks like this:
587  *      /(?:\x{DF}|[abc\x{DF}def])/ui
588  * where it uses the input unchanged in the middle of something it constructs,
589  * which is a branch for the DF outside the character class, and clustering
590  * parens around the whole thing. (It knows enough to skip the DF inside the
591  * class while in this substitute parse.) 'abc' and 'def' may have errors that
592  * need to be reported.  The general situation looks like this:
593  *
594  *              sI                       tI               xI       eI
595  * Input:       ----------------------------------------------------
596  * Constructed:         ---------------------------------------------------
597  *                      sC               tC               xC       eC     EC
598  *
599  * The input string sI..eI is the input pattern.  The string sC..EC is the
600  * constructed substitute parse string.  The portions sC..tC and eC..EC are
601  * constructed by us.  The portion tC..eC is an exact duplicate of the input
602  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
603  * while parsing, we find an error at xC.  We want to display a message showing
604  * the real input string.  Thus we need to find the point xI in it which
605  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
606  * been constructed by us, and so shouldn't have errors.  We get:
607  *
608  *      xI = sI + (tI - sI) + (xC - tC)
609  *
610  * and, the offset into sI is:
611  *
612  *      (xI - sI) = (tI - sI) + (xC - tC)
613  *
614  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
615  * and we save tC as RExC_adjusted_start.
616  *
617  * During normal processing of the input pattern, everything points to that,
618  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
619  */
620
621 #define tI_sI           RExC_precomp_adj
622 #define tC              RExC_adjusted_start
623 #define sC              RExC_precomp
624 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
625 #define xI(xC)          (sC + xI_offset(xC))
626 #define eC              RExC_precomp_end
627
628 #define REPORT_LOCATION_ARGS(xC)                                            \
629     UTF8fARG(UTF,                                                           \
630              (xI(xC) > eC) /* Don't run off end */                          \
631               ? eC - sC   /* Length before the <--HERE */                   \
632               : xI_offset(xC),                                              \
633              sC),         /* The input pattern printed up to the <--HERE */ \
634     UTF8fARG(UTF,                                                           \
635              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
636              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
637
638 /* Used to point after bad bytes for an error message, but avoid skipping
639  * past a nul byte. */
640 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
641
642 /*
643  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
644  * arg. Show regex, up to a maximum length. If it's too long, chop and add
645  * "...".
646  */
647 #define _FAIL(code) STMT_START {                                        \
648     const char *ellipses = "";                                          \
649     IV len = RExC_precomp_end - RExC_precomp;                                   \
650                                                                         \
651     if (!SIZE_ONLY)                                                     \
652         SAVEFREESV(RExC_rx_sv);                                         \
653     if (len > RegexLengthToShowInErrorMessages) {                       \
654         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
655         len = RegexLengthToShowInErrorMessages - 10;                    \
656         ellipses = "...";                                               \
657     }                                                                   \
658     code;                                                               \
659 } STMT_END
660
661 #define FAIL(msg) _FAIL(                            \
662     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
663             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
664
665 #define FAIL2(msg,arg) _FAIL(                       \
666     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
667             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
668
669 /*
670  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
671  */
672 #define Simple_vFAIL(m) STMT_START {                                    \
673     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
674             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
675 } STMT_END
676
677 /*
678  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
679  */
680 #define vFAIL(m) STMT_START {                           \
681     if (!SIZE_ONLY)                                     \
682         SAVEFREESV(RExC_rx_sv);                         \
683     Simple_vFAIL(m);                                    \
684 } STMT_END
685
686 /*
687  * Like Simple_vFAIL(), but accepts two arguments.
688  */
689 #define Simple_vFAIL2(m,a1) STMT_START {                        \
690     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
691                       REPORT_LOCATION_ARGS(RExC_parse));        \
692 } STMT_END
693
694 /*
695  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
696  */
697 #define vFAIL2(m,a1) STMT_START {                       \
698     if (!SIZE_ONLY)                                     \
699         SAVEFREESV(RExC_rx_sv);                         \
700     Simple_vFAIL2(m, a1);                               \
701 } STMT_END
702
703
704 /*
705  * Like Simple_vFAIL(), but accepts three arguments.
706  */
707 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
708     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
709             REPORT_LOCATION_ARGS(RExC_parse));                  \
710 } STMT_END
711
712 /*
713  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
714  */
715 #define vFAIL3(m,a1,a2) STMT_START {                    \
716     if (!SIZE_ONLY)                                     \
717         SAVEFREESV(RExC_rx_sv);                         \
718     Simple_vFAIL3(m, a1, a2);                           \
719 } STMT_END
720
721 /*
722  * Like Simple_vFAIL(), but accepts four arguments.
723  */
724 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
725     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
726             REPORT_LOCATION_ARGS(RExC_parse));                  \
727 } STMT_END
728
729 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
730     if (!SIZE_ONLY)                                     \
731         SAVEFREESV(RExC_rx_sv);                         \
732     Simple_vFAIL4(m, a1, a2, a3);                       \
733 } STMT_END
734
735 /* A specialized version of vFAIL2 that works with UTF8f */
736 #define vFAIL2utf8f(m, a1) STMT_START {             \
737     if (!SIZE_ONLY)                                 \
738         SAVEFREESV(RExC_rx_sv);                     \
739     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
740             REPORT_LOCATION_ARGS(RExC_parse));      \
741 } STMT_END
742
743 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
744     if (!SIZE_ONLY)                                     \
745         SAVEFREESV(RExC_rx_sv);                         \
746     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
747             REPORT_LOCATION_ARGS(RExC_parse));          \
748 } STMT_END
749
750 /* These have asserts in them because of [perl #122671] Many warnings in
751  * regcomp.c can occur twice.  If they get output in pass1 and later in that
752  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
753  * would get output again.  So they should be output in pass2, and these
754  * asserts make sure new warnings follow that paradigm. */
755
756 /* m is not necessarily a "literal string", in this macro */
757 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
758     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
759                                        "%s" REPORT_LOCATION,            \
760                                   m, REPORT_LOCATION_ARGS(loc));        \
761 } STMT_END
762
763 #define ckWARNreg(loc,m) STMT_START {                                   \
764     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
765                                           m REPORT_LOCATION,            \
766                                           REPORT_LOCATION_ARGS(loc));   \
767 } STMT_END
768
769 #define vWARN(loc, m) STMT_START {                                      \
770     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
771                                        m REPORT_LOCATION,               \
772                                        REPORT_LOCATION_ARGS(loc));      \
773 } STMT_END
774
775 #define vWARN_dep(loc, m) STMT_START {                                  \
776     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
777                                        m REPORT_LOCATION,               \
778                                        REPORT_LOCATION_ARGS(loc));      \
779 } STMT_END
780
781 #define ckWARNdep(loc,m) STMT_START {                                   \
782     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
783                                             m REPORT_LOCATION,          \
784                                             REPORT_LOCATION_ARGS(loc)); \
785 } STMT_END
786
787 #define ckWARNregdep(loc,m) STMT_START {                                    \
788     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
789                                                       WARN_REGEXP),         \
790                                              m REPORT_LOCATION,             \
791                                              REPORT_LOCATION_ARGS(loc));    \
792 } STMT_END
793
794 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
795     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
796                                             m REPORT_LOCATION,              \
797                                             a1, REPORT_LOCATION_ARGS(loc)); \
798 } STMT_END
799
800 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
801     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
802                                           m REPORT_LOCATION,                \
803                                           a1, REPORT_LOCATION_ARGS(loc));   \
804 } STMT_END
805
806 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
807     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
808                                        m REPORT_LOCATION,                   \
809                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
810 } STMT_END
811
812 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
813     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
814                                           m REPORT_LOCATION,                \
815                                           a1, a2,                           \
816                                           REPORT_LOCATION_ARGS(loc));       \
817 } STMT_END
818
819 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
820     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
821                                        m REPORT_LOCATION,               \
822                                        a1, a2, a3,                      \
823                                        REPORT_LOCATION_ARGS(loc));      \
824 } STMT_END
825
826 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
827     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
828                                           m REPORT_LOCATION,            \
829                                           a1, a2, a3,                   \
830                                           REPORT_LOCATION_ARGS(loc));   \
831 } STMT_END
832
833 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
834     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
835                                        m REPORT_LOCATION,               \
836                                        a1, a2, a3, a4,                  \
837                                        REPORT_LOCATION_ARGS(loc));      \
838 } STMT_END
839
840 /* Macros for recording node offsets.   20001227 mjd@plover.com
841  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
842  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
843  * Element 0 holds the number n.
844  * Position is 1 indexed.
845  */
846 #ifndef RE_TRACK_PATTERN_OFFSETS
847 #define Set_Node_Offset_To_R(node,byte)
848 #define Set_Node_Offset(node,byte)
849 #define Set_Cur_Node_Offset
850 #define Set_Node_Length_To_R(node,len)
851 #define Set_Node_Length(node,len)
852 #define Set_Node_Cur_Length(node,start)
853 #define Node_Offset(n)
854 #define Node_Length(n)
855 #define Set_Node_Offset_Length(node,offset,len)
856 #define ProgLen(ri) ri->u.proglen
857 #define SetProgLen(ri,x) ri->u.proglen = x
858 #else
859 #define ProgLen(ri) ri->u.offsets[0]
860 #define SetProgLen(ri,x) ri->u.offsets[0] = x
861 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
862     if (! SIZE_ONLY) {                                                  \
863         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
864                     __LINE__, (int)(node), (int)(byte)));               \
865         if((node) < 0) {                                                \
866             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
867                                          (int)(node));                  \
868         } else {                                                        \
869             RExC_offsets[2*(node)-1] = (byte);                          \
870         }                                                               \
871     }                                                                   \
872 } STMT_END
873
874 #define Set_Node_Offset(node,byte) \
875     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
876 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
877
878 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
879     if (! SIZE_ONLY) {                                                  \
880         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
881                 __LINE__, (int)(node), (int)(len)));                    \
882         if((node) < 0) {                                                \
883             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
884                                          (int)(node));                  \
885         } else {                                                        \
886             RExC_offsets[2*(node)] = (len);                             \
887         }                                                               \
888     }                                                                   \
889 } STMT_END
890
891 #define Set_Node_Length(node,len) \
892     Set_Node_Length_To_R((node)-RExC_emit_start, len)
893 #define Set_Node_Cur_Length(node, start)                \
894     Set_Node_Length(node, RExC_parse - start)
895
896 /* Get offsets and lengths */
897 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
898 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
899
900 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
901     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
902     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
903 } STMT_END
904 #endif
905
906 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
907 #define EXPERIMENTAL_INPLACESCAN
908 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
909
910 #ifdef DEBUGGING
911 int
912 Perl_re_printf(pTHX_ const char *fmt, ...)
913 {
914     va_list ap;
915     int result;
916     PerlIO *f= Perl_debug_log;
917     PERL_ARGS_ASSERT_RE_PRINTF;
918     va_start(ap, fmt);
919     result = PerlIO_vprintf(f, fmt, ap);
920     va_end(ap);
921     return result;
922 }
923
924 int
925 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
926 {
927     va_list ap;
928     int result;
929     PerlIO *f= Perl_debug_log;
930     PERL_ARGS_ASSERT_RE_INDENTF;
931     va_start(ap, depth);
932     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
933     result = PerlIO_vprintf(f, fmt, ap);
934     va_end(ap);
935     return result;
936 }
937 #endif /* DEBUGGING */
938
939 #define DEBUG_RExC_seen()                                                   \
940         DEBUG_OPTIMISE_MORE_r({                                             \
941             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
942                                                                             \
943             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
944                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
945                                                                             \
946             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
947                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
948                                                                             \
949             if (RExC_seen & REG_GPOS_SEEN)                                  \
950                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
951                                                                             \
952             if (RExC_seen & REG_RECURSE_SEEN)                               \
953                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
954                                                                             \
955             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
956                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
957                                                                             \
958             if (RExC_seen & REG_VERBARG_SEEN)                               \
959                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
960                                                                             \
961             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
962                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
963                                                                             \
964             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
965                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
966                                                                             \
967             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
968                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
969                                                                             \
970             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
971                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
972                                                                             \
973             Perl_re_printf( aTHX_ "\n");                                                \
974         });
975
976 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
977   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
978
979 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
980     if ( ( flags ) ) {                                                      \
981         Perl_re_printf( aTHX_  "%s", open_str);                                         \
982         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
983         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
984         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
985         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
986         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
987         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
988         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
989         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
990         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
991         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
992         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
993         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
994         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
995         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
996         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
997         Perl_re_printf( aTHX_  "%s", close_str);                                        \
998     }
999
1000
1001 #define DEBUG_STUDYDATA(str,data,depth)                              \
1002 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
1003     Perl_re_indentf( aTHX_  "" str "Pos:%" IVdf "/%" IVdf            \
1004         " Flags: 0x%" UVXf,                                          \
1005         depth,                                                       \
1006         (IV)((data)->pos_min),                                       \
1007         (IV)((data)->pos_delta),                                     \
1008         (UV)((data)->flags)                                          \
1009     );                                                               \
1010     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
1011     Perl_re_printf( aTHX_                                            \
1012         " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",                    \
1013         (IV)((data)->whilem_c),                                      \
1014         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
1015         is_inf ? "INF " : ""                                         \
1016     );                                                               \
1017     if ((data)->last_found)                                          \
1018         Perl_re_printf( aTHX_                                        \
1019             "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf                   \
1020             " %sFixed:'%s' @ %" IVdf                                 \
1021             " %sFloat: '%s' @ %" IVdf "/%" IVdf,                     \
1022             SvPVX_const((data)->last_found),                         \
1023             (IV)((data)->last_end),                                  \
1024             (IV)((data)->last_start_min),                            \
1025             (IV)((data)->last_start_max),                            \
1026             ((data)->longest &&                                      \
1027              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
1028             SvPVX_const((data)->longest_fixed),                      \
1029             (IV)((data)->offset_fixed),                              \
1030             ((data)->longest &&                                      \
1031              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
1032             SvPVX_const((data)->longest_float),                      \
1033             (IV)((data)->offset_float_min),                          \
1034             (IV)((data)->offset_float_max)                           \
1035         );                                                           \
1036     Perl_re_printf( aTHX_ "\n");                                                 \
1037 });
1038
1039
1040 /* =========================================================
1041  * BEGIN edit_distance stuff.
1042  *
1043  * This calculates how many single character changes of any type are needed to
1044  * transform a string into another one.  It is taken from version 3.1 of
1045  *
1046  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1047  */
1048
1049 /* Our unsorted dictionary linked list.   */
1050 /* Note we use UVs, not chars. */
1051
1052 struct dictionary{
1053   UV key;
1054   UV value;
1055   struct dictionary* next;
1056 };
1057 typedef struct dictionary item;
1058
1059
1060 PERL_STATIC_INLINE item*
1061 push(UV key,item* curr)
1062 {
1063     item* head;
1064     Newxz(head, 1, item);
1065     head->key = key;
1066     head->value = 0;
1067     head->next = curr;
1068     return head;
1069 }
1070
1071
1072 PERL_STATIC_INLINE item*
1073 find(item* head, UV key)
1074 {
1075     item* iterator = head;
1076     while (iterator){
1077         if (iterator->key == key){
1078             return iterator;
1079         }
1080         iterator = iterator->next;
1081     }
1082
1083     return NULL;
1084 }
1085
1086 PERL_STATIC_INLINE item*
1087 uniquePush(item* head,UV key)
1088 {
1089     item* iterator = head;
1090
1091     while (iterator){
1092         if (iterator->key == key) {
1093             return head;
1094         }
1095         iterator = iterator->next;
1096     }
1097
1098     return push(key,head);
1099 }
1100
1101 PERL_STATIC_INLINE void
1102 dict_free(item* head)
1103 {
1104     item* iterator = head;
1105
1106     while (iterator) {
1107         item* temp = iterator;
1108         iterator = iterator->next;
1109         Safefree(temp);
1110     }
1111
1112     head = NULL;
1113 }
1114
1115 /* End of Dictionary Stuff */
1116
1117 /* All calculations/work are done here */
1118 STATIC int
1119 S_edit_distance(const UV* src,
1120                 const UV* tgt,
1121                 const STRLEN x,             /* length of src[] */
1122                 const STRLEN y,             /* length of tgt[] */
1123                 const SSize_t maxDistance
1124 )
1125 {
1126     item *head = NULL;
1127     UV swapCount,swapScore,targetCharCount,i,j;
1128     UV *scores;
1129     UV score_ceil = x + y;
1130
1131     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1132
1133     /* intialize matrix start values */
1134     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1135     scores[0] = score_ceil;
1136     scores[1 * (y + 2) + 0] = score_ceil;
1137     scores[0 * (y + 2) + 1] = score_ceil;
1138     scores[1 * (y + 2) + 1] = 0;
1139     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1140
1141     /* work loops    */
1142     /* i = src index */
1143     /* j = tgt index */
1144     for (i=1;i<=x;i++) {
1145         if (i < x)
1146             head = uniquePush(head,src[i]);
1147         scores[(i+1) * (y + 2) + 1] = i;
1148         scores[(i+1) * (y + 2) + 0] = score_ceil;
1149         swapCount = 0;
1150
1151         for (j=1;j<=y;j++) {
1152             if (i == 1) {
1153                 if(j < y)
1154                 head = uniquePush(head,tgt[j]);
1155                 scores[1 * (y + 2) + (j + 1)] = j;
1156                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1157             }
1158
1159             targetCharCount = find(head,tgt[j-1])->value;
1160             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1161
1162             if (src[i-1] != tgt[j-1]){
1163                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(swapScore,(MIN(scores[i * (y + 2) + j], MIN(scores[(i+1) * (y + 2) + j], scores[i * (y + 2) + (j + 1)])) + 1));
1164             }
1165             else {
1166                 swapCount = j;
1167                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1168             }
1169         }
1170
1171         find(head,src[i-1])->value = i;
1172     }
1173
1174     {
1175         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1176         dict_free(head);
1177         Safefree(scores);
1178         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1179     }
1180 }
1181
1182 /* END of edit_distance() stuff
1183  * ========================================================= */
1184
1185 /* is c a control character for which we have a mnemonic? */
1186 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1187
1188 STATIC const char *
1189 S_cntrl_to_mnemonic(const U8 c)
1190 {
1191     /* Returns the mnemonic string that represents character 'c', if one
1192      * exists; NULL otherwise.  The only ones that exist for the purposes of
1193      * this routine are a few control characters */
1194
1195     switch (c) {
1196         case '\a':       return "\\a";
1197         case '\b':       return "\\b";
1198         case ESC_NATIVE: return "\\e";
1199         case '\f':       return "\\f";
1200         case '\n':       return "\\n";
1201         case '\r':       return "\\r";
1202         case '\t':       return "\\t";
1203     }
1204
1205     return NULL;
1206 }
1207
1208 /* Mark that we cannot extend a found fixed substring at this point.
1209    Update the longest found anchored substring and the longest found
1210    floating substrings if needed. */
1211
1212 STATIC void
1213 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1214                     SSize_t *minlenp, int is_inf)
1215 {
1216     const STRLEN l = CHR_SVLEN(data->last_found);
1217     const STRLEN old_l = CHR_SVLEN(*data->longest);
1218     GET_RE_DEBUG_FLAGS_DECL;
1219
1220     PERL_ARGS_ASSERT_SCAN_COMMIT;
1221
1222     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1223         SvSetMagicSV(*data->longest, data->last_found);
1224         if (*data->longest == data->longest_fixed) {
1225             data->offset_fixed = l ? data->last_start_min : data->pos_min;
1226             if (data->flags & SF_BEFORE_EOL)
1227                 data->flags
1228                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
1229             else
1230                 data->flags &= ~SF_FIX_BEFORE_EOL;
1231             data->minlen_fixed=minlenp;
1232             data->lookbehind_fixed=0;
1233         }
1234         else { /* *data->longest == data->longest_float */
1235             data->offset_float_min = l ? data->last_start_min : data->pos_min;
1236             data->offset_float_max = (l
1237                           ? data->last_start_max
1238                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1239                                          ? SSize_t_MAX
1240                                          : data->pos_min + data->pos_delta));
1241             if (is_inf
1242                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
1243                 data->offset_float_max = SSize_t_MAX;
1244             if (data->flags & SF_BEFORE_EOL)
1245                 data->flags
1246                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
1247             else
1248                 data->flags &= ~SF_FL_BEFORE_EOL;
1249             data->minlen_float=minlenp;
1250             data->lookbehind_float=0;
1251         }
1252     }
1253     SvCUR_set(data->last_found, 0);
1254     {
1255         SV * const sv = data->last_found;
1256         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1257             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1258             if (mg)
1259                 mg->mg_len = 0;
1260         }
1261     }
1262     data->last_end = -1;
1263     data->flags &= ~SF_BEFORE_EOL;
1264     DEBUG_STUDYDATA("commit: ",data,0);
1265 }
1266
1267 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1268  * list that describes which code points it matches */
1269
1270 STATIC void
1271 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1272 {
1273     /* Set the SSC 'ssc' to match an empty string or any code point */
1274
1275     PERL_ARGS_ASSERT_SSC_ANYTHING;
1276
1277     assert(is_ANYOF_SYNTHETIC(ssc));
1278
1279     /* mortalize so won't leak */
1280     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1281     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1282 }
1283
1284 STATIC int
1285 S_ssc_is_anything(const regnode_ssc *ssc)
1286 {
1287     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1288      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1289      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1290      * in any way, so there's no point in using it */
1291
1292     UV start, end;
1293     bool ret;
1294
1295     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1296
1297     assert(is_ANYOF_SYNTHETIC(ssc));
1298
1299     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1300         return FALSE;
1301     }
1302
1303     /* See if the list consists solely of the range 0 - Infinity */
1304     invlist_iterinit(ssc->invlist);
1305     ret = invlist_iternext(ssc->invlist, &start, &end)
1306           && start == 0
1307           && end == UV_MAX;
1308
1309     invlist_iterfinish(ssc->invlist);
1310
1311     if (ret) {
1312         return TRUE;
1313     }
1314
1315     /* If e.g., both \w and \W are set, matches everything */
1316     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1317         int i;
1318         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1319             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1320                 return TRUE;
1321             }
1322         }
1323     }
1324
1325     return FALSE;
1326 }
1327
1328 STATIC void
1329 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1330 {
1331     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1332      * string, any code point, or any posix class under locale */
1333
1334     PERL_ARGS_ASSERT_SSC_INIT;
1335
1336     Zero(ssc, 1, regnode_ssc);
1337     set_ANYOF_SYNTHETIC(ssc);
1338     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1339     ssc_anything(ssc);
1340
1341     /* If any portion of the regex is to operate under locale rules that aren't
1342      * fully known at compile time, initialization includes it.  The reason
1343      * this isn't done for all regexes is that the optimizer was written under
1344      * the assumption that locale was all-or-nothing.  Given the complexity and
1345      * lack of documentation in the optimizer, and that there are inadequate
1346      * test cases for locale, many parts of it may not work properly, it is
1347      * safest to avoid locale unless necessary. */
1348     if (RExC_contains_locale) {
1349         ANYOF_POSIXL_SETALL(ssc);
1350     }
1351     else {
1352         ANYOF_POSIXL_ZERO(ssc);
1353     }
1354 }
1355
1356 STATIC int
1357 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1358                         const regnode_ssc *ssc)
1359 {
1360     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1361      * to the list of code points matched, and locale posix classes; hence does
1362      * not check its flags) */
1363
1364     UV start, end;
1365     bool ret;
1366
1367     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1368
1369     assert(is_ANYOF_SYNTHETIC(ssc));
1370
1371     invlist_iterinit(ssc->invlist);
1372     ret = invlist_iternext(ssc->invlist, &start, &end)
1373           && start == 0
1374           && end == UV_MAX;
1375
1376     invlist_iterfinish(ssc->invlist);
1377
1378     if (! ret) {
1379         return FALSE;
1380     }
1381
1382     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1383         return FALSE;
1384     }
1385
1386     return TRUE;
1387 }
1388
1389 STATIC SV*
1390 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1391                                const regnode_charclass* const node)
1392 {
1393     /* Returns a mortal inversion list defining which code points are matched
1394      * by 'node', which is of type ANYOF.  Handles complementing the result if
1395      * appropriate.  If some code points aren't knowable at this time, the
1396      * returned list must, and will, contain every code point that is a
1397      * possibility. */
1398
1399     SV* invlist = NULL;
1400     SV* only_utf8_locale_invlist = NULL;
1401     unsigned int i;
1402     const U32 n = ARG(node);
1403     bool new_node_has_latin1 = FALSE;
1404
1405     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1406
1407     /* Look at the data structure created by S_set_ANYOF_arg() */
1408     if (n != ANYOF_ONLY_HAS_BITMAP) {
1409         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1410         AV * const av = MUTABLE_AV(SvRV(rv));
1411         SV **const ary = AvARRAY(av);
1412         assert(RExC_rxi->data->what[n] == 's');
1413
1414         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1415             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1416         }
1417         else if (ary[0] && ary[0] != &PL_sv_undef) {
1418
1419             /* Here, no compile-time swash, and there are things that won't be
1420              * known until runtime -- we have to assume it could be anything */
1421             invlist = sv_2mortal(_new_invlist(1));
1422             return _add_range_to_invlist(invlist, 0, UV_MAX);
1423         }
1424         else if (ary[3] && ary[3] != &PL_sv_undef) {
1425
1426             /* Here no compile-time swash, and no run-time only data.  Use the
1427              * node's inversion list */
1428             invlist = sv_2mortal(invlist_clone(ary[3]));
1429         }
1430
1431         /* Get the code points valid only under UTF-8 locales */
1432         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1433             && ary[2] && ary[2] != &PL_sv_undef)
1434         {
1435             only_utf8_locale_invlist = ary[2];
1436         }
1437     }
1438
1439     if (! invlist) {
1440         invlist = sv_2mortal(_new_invlist(0));
1441     }
1442
1443     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1444      * code points, and an inversion list for the others, but if there are code
1445      * points that should match only conditionally on the target string being
1446      * UTF-8, those are placed in the inversion list, and not the bitmap.
1447      * Since there are circumstances under which they could match, they are
1448      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1449      * to exclude them here, so that when we invert below, the end result
1450      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1451      * have to do this here before we add the unconditionally matched code
1452      * points */
1453     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1454         _invlist_intersection_complement_2nd(invlist,
1455                                              PL_UpperLatin1,
1456                                              &invlist);
1457     }
1458
1459     /* Add in the points from the bit map */
1460     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1461         if (ANYOF_BITMAP_TEST(node, i)) {
1462             unsigned int start = i++;
1463
1464             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1465                 /* empty */
1466             }
1467             invlist = _add_range_to_invlist(invlist, start, i-1);
1468             new_node_has_latin1 = TRUE;
1469         }
1470     }
1471
1472     /* If this can match all upper Latin1 code points, have to add them
1473      * as well.  But don't add them if inverting, as when that gets done below,
1474      * it would exclude all these characters, including the ones it shouldn't
1475      * that were added just above */
1476     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1477         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1478     {
1479         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1480     }
1481
1482     /* Similarly for these */
1483     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1484         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1485     }
1486
1487     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1488         _invlist_invert(invlist);
1489     }
1490     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1491
1492         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1493          * locale.  We can skip this if there are no 0-255 at all. */
1494         _invlist_union(invlist, PL_Latin1, &invlist);
1495     }
1496
1497     /* Similarly add the UTF-8 locale possible matches.  These have to be
1498      * deferred until after the non-UTF-8 locale ones are taken care of just
1499      * above, or it leads to wrong results under ANYOF_INVERT */
1500     if (only_utf8_locale_invlist) {
1501         _invlist_union_maybe_complement_2nd(invlist,
1502                                             only_utf8_locale_invlist,
1503                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1504                                             &invlist);
1505     }
1506
1507     return invlist;
1508 }
1509
1510 /* These two functions currently do the exact same thing */
1511 #define ssc_init_zero           ssc_init
1512
1513 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1514 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1515
1516 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1517  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1518  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1519
1520 STATIC void
1521 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1522                 const regnode_charclass *and_with)
1523 {
1524     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1525      * another SSC or a regular ANYOF class.  Can create false positives. */
1526
1527     SV* anded_cp_list;
1528     U8  anded_flags;
1529
1530     PERL_ARGS_ASSERT_SSC_AND;
1531
1532     assert(is_ANYOF_SYNTHETIC(ssc));
1533
1534     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1535      * the code point inversion list and just the relevant flags */
1536     if (is_ANYOF_SYNTHETIC(and_with)) {
1537         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1538         anded_flags = ANYOF_FLAGS(and_with);
1539
1540         /* XXX This is a kludge around what appears to be deficiencies in the
1541          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1542          * there are paths through the optimizer where it doesn't get weeded
1543          * out when it should.  And if we don't make some extra provision for
1544          * it like the code just below, it doesn't get added when it should.
1545          * This solution is to add it only when AND'ing, which is here, and
1546          * only when what is being AND'ed is the pristine, original node
1547          * matching anything.  Thus it is like adding it to ssc_anything() but
1548          * only when the result is to be AND'ed.  Probably the same solution
1549          * could be adopted for the same problem we have with /l matching,
1550          * which is solved differently in S_ssc_init(), and that would lead to
1551          * fewer false positives than that solution has.  But if this solution
1552          * creates bugs, the consequences are only that a warning isn't raised
1553          * that should be; while the consequences for having /l bugs is
1554          * incorrect matches */
1555         if (ssc_is_anything((regnode_ssc *)and_with)) {
1556             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1557         }
1558     }
1559     else {
1560         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1561         if (OP(and_with) == ANYOFD) {
1562             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1563         }
1564         else {
1565             anded_flags = ANYOF_FLAGS(and_with)
1566             &( ANYOF_COMMON_FLAGS
1567               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1568               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1569             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1570                 anded_flags &=
1571                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1572             }
1573         }
1574     }
1575
1576     ANYOF_FLAGS(ssc) &= anded_flags;
1577
1578     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1579      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1580      * 'and_with' may be inverted.  When not inverted, we have the situation of
1581      * computing:
1582      *  (C1 | P1) & (C2 | P2)
1583      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1584      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1585      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1586      *                    <=  ((C1 & C2) | P1 | P2)
1587      * Alternatively, the last few steps could be:
1588      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1589      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1590      *                    <=  (C1 | C2 | (P1 & P2))
1591      * We favor the second approach if either P1 or P2 is non-empty.  This is
1592      * because these components are a barrier to doing optimizations, as what
1593      * they match cannot be known until the moment of matching as they are
1594      * dependent on the current locale, 'AND"ing them likely will reduce or
1595      * eliminate them.
1596      * But we can do better if we know that C1,P1 are in their initial state (a
1597      * frequent occurrence), each matching everything:
1598      *  (<everything>) & (C2 | P2) =  C2 | P2
1599      * Similarly, if C2,P2 are in their initial state (again a frequent
1600      * occurrence), the result is a no-op
1601      *  (C1 | P1) & (<everything>) =  C1 | P1
1602      *
1603      * Inverted, we have
1604      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1605      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1606      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1607      * */
1608
1609     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1610         && ! is_ANYOF_SYNTHETIC(and_with))
1611     {
1612         unsigned int i;
1613
1614         ssc_intersection(ssc,
1615                          anded_cp_list,
1616                          FALSE /* Has already been inverted */
1617                          );
1618
1619         /* If either P1 or P2 is empty, the intersection will be also; can skip
1620          * the loop */
1621         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1622             ANYOF_POSIXL_ZERO(ssc);
1623         }
1624         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1625
1626             /* Note that the Posix class component P from 'and_with' actually
1627              * looks like:
1628              *      P = Pa | Pb | ... | Pn
1629              * where each component is one posix class, such as in [\w\s].
1630              * Thus
1631              *      ~P = ~(Pa | Pb | ... | Pn)
1632              *         = ~Pa & ~Pb & ... & ~Pn
1633              *        <= ~Pa | ~Pb | ... | ~Pn
1634              * The last is something we can easily calculate, but unfortunately
1635              * is likely to have many false positives.  We could do better
1636              * in some (but certainly not all) instances if two classes in
1637              * P have known relationships.  For example
1638              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1639              * So
1640              *      :lower: & :print: = :lower:
1641              * And similarly for classes that must be disjoint.  For example,
1642              * since \s and \w can have no elements in common based on rules in
1643              * the POSIX standard,
1644              *      \w & ^\S = nothing
1645              * Unfortunately, some vendor locales do not meet the Posix
1646              * standard, in particular almost everything by Microsoft.
1647              * The loop below just changes e.g., \w into \W and vice versa */
1648
1649             regnode_charclass_posixl temp;
1650             int add = 1;    /* To calculate the index of the complement */
1651
1652             ANYOF_POSIXL_ZERO(&temp);
1653             for (i = 0; i < ANYOF_MAX; i++) {
1654                 assert(i % 2 != 0
1655                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1656                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1657
1658                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1659                     ANYOF_POSIXL_SET(&temp, i + add);
1660                 }
1661                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1662             }
1663             ANYOF_POSIXL_AND(&temp, ssc);
1664
1665         } /* else ssc already has no posixes */
1666     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1667          in its initial state */
1668     else if (! is_ANYOF_SYNTHETIC(and_with)
1669              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1670     {
1671         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1672          * copy it over 'ssc' */
1673         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1674             if (is_ANYOF_SYNTHETIC(and_with)) {
1675                 StructCopy(and_with, ssc, regnode_ssc);
1676             }
1677             else {
1678                 ssc->invlist = anded_cp_list;
1679                 ANYOF_POSIXL_ZERO(ssc);
1680                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1681                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1682                 }
1683             }
1684         }
1685         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1686                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1687         {
1688             /* One or the other of P1, P2 is non-empty. */
1689             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1690                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1691             }
1692             ssc_union(ssc, anded_cp_list, FALSE);
1693         }
1694         else { /* P1 = P2 = empty */
1695             ssc_intersection(ssc, anded_cp_list, FALSE);
1696         }
1697     }
1698 }
1699
1700 STATIC void
1701 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1702                const regnode_charclass *or_with)
1703 {
1704     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1705      * another SSC or a regular ANYOF class.  Can create false positives if
1706      * 'or_with' is to be inverted. */
1707
1708     SV* ored_cp_list;
1709     U8 ored_flags;
1710
1711     PERL_ARGS_ASSERT_SSC_OR;
1712
1713     assert(is_ANYOF_SYNTHETIC(ssc));
1714
1715     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1716      * the code point inversion list and just the relevant flags */
1717     if (is_ANYOF_SYNTHETIC(or_with)) {
1718         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1719         ored_flags = ANYOF_FLAGS(or_with);
1720     }
1721     else {
1722         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1723         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1724         if (OP(or_with) != ANYOFD) {
1725             ored_flags
1726             |= ANYOF_FLAGS(or_with)
1727              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1728                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1729             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1730                 ored_flags |=
1731                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1732             }
1733         }
1734     }
1735
1736     ANYOF_FLAGS(ssc) |= ored_flags;
1737
1738     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1739      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1740      * 'or_with' may be inverted.  When not inverted, we have the simple
1741      * situation of computing:
1742      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1743      * If P1|P2 yields a situation with both a class and its complement are
1744      * set, like having both \w and \W, this matches all code points, and we
1745      * can delete these from the P component of the ssc going forward.  XXX We
1746      * might be able to delete all the P components, but I (khw) am not certain
1747      * about this, and it is better to be safe.
1748      *
1749      * Inverted, we have
1750      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1751      *                         <=  (C1 | P1) | ~C2
1752      *                         <=  (C1 | ~C2) | P1
1753      * (which results in actually simpler code than the non-inverted case)
1754      * */
1755
1756     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1757         && ! is_ANYOF_SYNTHETIC(or_with))
1758     {
1759         /* We ignore P2, leaving P1 going forward */
1760     }   /* else  Not inverted */
1761     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1762         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1763         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1764             unsigned int i;
1765             for (i = 0; i < ANYOF_MAX; i += 2) {
1766                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1767                 {
1768                     ssc_match_all_cp(ssc);
1769                     ANYOF_POSIXL_CLEAR(ssc, i);
1770                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1771                 }
1772             }
1773         }
1774     }
1775
1776     ssc_union(ssc,
1777               ored_cp_list,
1778               FALSE /* Already has been inverted */
1779               );
1780 }
1781
1782 PERL_STATIC_INLINE void
1783 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1784 {
1785     PERL_ARGS_ASSERT_SSC_UNION;
1786
1787     assert(is_ANYOF_SYNTHETIC(ssc));
1788
1789     _invlist_union_maybe_complement_2nd(ssc->invlist,
1790                                         invlist,
1791                                         invert2nd,
1792                                         &ssc->invlist);
1793 }
1794
1795 PERL_STATIC_INLINE void
1796 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1797                          SV* const invlist,
1798                          const bool invert2nd)
1799 {
1800     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1801
1802     assert(is_ANYOF_SYNTHETIC(ssc));
1803
1804     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1805                                                invlist,
1806                                                invert2nd,
1807                                                &ssc->invlist);
1808 }
1809
1810 PERL_STATIC_INLINE void
1811 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1812 {
1813     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1814
1815     assert(is_ANYOF_SYNTHETIC(ssc));
1816
1817     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1818 }
1819
1820 PERL_STATIC_INLINE void
1821 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1822 {
1823     /* AND just the single code point 'cp' into the SSC 'ssc' */
1824
1825     SV* cp_list = _new_invlist(2);
1826
1827     PERL_ARGS_ASSERT_SSC_CP_AND;
1828
1829     assert(is_ANYOF_SYNTHETIC(ssc));
1830
1831     cp_list = add_cp_to_invlist(cp_list, cp);
1832     ssc_intersection(ssc, cp_list,
1833                      FALSE /* Not inverted */
1834                      );
1835     SvREFCNT_dec_NN(cp_list);
1836 }
1837
1838 PERL_STATIC_INLINE void
1839 S_ssc_clear_locale(regnode_ssc *ssc)
1840 {
1841     /* Set the SSC 'ssc' to not match any locale things */
1842     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1843
1844     assert(is_ANYOF_SYNTHETIC(ssc));
1845
1846     ANYOF_POSIXL_ZERO(ssc);
1847     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1848 }
1849
1850 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1851
1852 STATIC bool
1853 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1854 {
1855     /* The synthetic start class is used to hopefully quickly winnow down
1856      * places where a pattern could start a match in the target string.  If it
1857      * doesn't really narrow things down that much, there isn't much point to
1858      * having the overhead of using it.  This function uses some very crude
1859      * heuristics to decide if to use the ssc or not.
1860      *
1861      * It returns TRUE if 'ssc' rules out more than half what it considers to
1862      * be the "likely" possible matches, but of course it doesn't know what the
1863      * actual things being matched are going to be; these are only guesses
1864      *
1865      * For /l matches, it assumes that the only likely matches are going to be
1866      *      in the 0-255 range, uniformly distributed, so half of that is 127
1867      * For /a and /d matches, it assumes that the likely matches will be just
1868      *      the ASCII range, so half of that is 63
1869      * For /u and there isn't anything matching above the Latin1 range, it
1870      *      assumes that that is the only range likely to be matched, and uses
1871      *      half that as the cut-off: 127.  If anything matches above Latin1,
1872      *      it assumes that all of Unicode could match (uniformly), except for
1873      *      non-Unicode code points and things in the General Category "Other"
1874      *      (unassigned, private use, surrogates, controls and formats).  This
1875      *      is a much large number. */
1876
1877     U32 count = 0;      /* Running total of number of code points matched by
1878                            'ssc' */
1879     UV start, end;      /* Start and end points of current range in inversion
1880                            list */
1881     const U32 max_code_points = (LOC)
1882                                 ?  256
1883                                 : ((   ! UNI_SEMANTICS
1884                                      || invlist_highest(ssc->invlist) < 256)
1885                                   ? 128
1886                                   : NON_OTHER_COUNT);
1887     const U32 max_match = max_code_points / 2;
1888
1889     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1890
1891     invlist_iterinit(ssc->invlist);
1892     while (invlist_iternext(ssc->invlist, &start, &end)) {
1893         if (start >= max_code_points) {
1894             break;
1895         }
1896         end = MIN(end, max_code_points - 1);
1897         count += end - start + 1;
1898         if (count >= max_match) {
1899             invlist_iterfinish(ssc->invlist);
1900             return FALSE;
1901         }
1902     }
1903
1904     return TRUE;
1905 }
1906
1907
1908 STATIC void
1909 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1910 {
1911     /* The inversion list in the SSC is marked mortal; now we need a more
1912      * permanent copy, which is stored the same way that is done in a regular
1913      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1914      * map */
1915
1916     SV* invlist = invlist_clone(ssc->invlist);
1917
1918     PERL_ARGS_ASSERT_SSC_FINALIZE;
1919
1920     assert(is_ANYOF_SYNTHETIC(ssc));
1921
1922     /* The code in this file assumes that all but these flags aren't relevant
1923      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1924      * by the time we reach here */
1925     assert(! (ANYOF_FLAGS(ssc)
1926         & ~( ANYOF_COMMON_FLAGS
1927             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1928             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
1929
1930     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1931
1932     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1933                                 NULL, NULL, NULL, FALSE);
1934
1935     /* Make sure is clone-safe */
1936     ssc->invlist = NULL;
1937
1938     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1939         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1940     }
1941
1942     if (RExC_contains_locale) {
1943         OP(ssc) = ANYOFL;
1944     }
1945
1946     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1947 }
1948
1949 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1950 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1951 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1952 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1953                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1954                                : 0 )
1955
1956
1957 #ifdef DEBUGGING
1958 /*
1959    dump_trie(trie,widecharmap,revcharmap)
1960    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1961    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1962
1963    These routines dump out a trie in a somewhat readable format.
1964    The _interim_ variants are used for debugging the interim
1965    tables that are used to generate the final compressed
1966    representation which is what dump_trie expects.
1967
1968    Part of the reason for their existence is to provide a form
1969    of documentation as to how the different representations function.
1970
1971 */
1972
1973 /*
1974   Dumps the final compressed table form of the trie to Perl_debug_log.
1975   Used for debugging make_trie().
1976 */
1977
1978 STATIC void
1979 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1980             AV *revcharmap, U32 depth)
1981 {
1982     U32 state;
1983     SV *sv=sv_newmortal();
1984     int colwidth= widecharmap ? 6 : 4;
1985     U16 word;
1986     GET_RE_DEBUG_FLAGS_DECL;
1987
1988     PERL_ARGS_ASSERT_DUMP_TRIE;
1989
1990     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
1991         depth+1, "Match","Base","Ofs" );
1992
1993     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1994         SV ** const tmp = av_fetch( revcharmap, state, 0);
1995         if ( tmp ) {
1996             Perl_re_printf( aTHX_  "%*s",
1997                 colwidth,
1998                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1999                             PL_colors[0], PL_colors[1],
2000                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2001                             PERL_PV_ESCAPE_FIRSTCHAR
2002                 )
2003             );
2004         }
2005     }
2006     Perl_re_printf( aTHX_  "\n");
2007     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2008
2009     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2010         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2011     Perl_re_printf( aTHX_  "\n");
2012
2013     for( state = 1 ; state < trie->statecount ; state++ ) {
2014         const U32 base = trie->states[ state ].trans.base;
2015
2016         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2017
2018         if ( trie->states[ state ].wordnum ) {
2019             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2020         } else {
2021             Perl_re_printf( aTHX_  "%6s", "" );
2022         }
2023
2024         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2025
2026         if ( base ) {
2027             U32 ofs = 0;
2028
2029             while( ( base + ofs  < trie->uniquecharcount ) ||
2030                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2031                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2032                                                                     != state))
2033                     ofs++;
2034
2035             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2036
2037             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2038                 if ( ( base + ofs >= trie->uniquecharcount )
2039                         && ( base + ofs - trie->uniquecharcount
2040                                                         < trie->lasttrans )
2041                         && trie->trans[ base + ofs
2042                                     - trie->uniquecharcount ].check == state )
2043                 {
2044                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2045                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2046                    );
2047                 } else {
2048                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2049                 }
2050             }
2051
2052             Perl_re_printf( aTHX_  "]");
2053
2054         }
2055         Perl_re_printf( aTHX_  "\n" );
2056     }
2057     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2058                                 depth);
2059     for (word=1; word <= trie->wordcount; word++) {
2060         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2061             (int)word, (int)(trie->wordinfo[word].prev),
2062             (int)(trie->wordinfo[word].len));
2063     }
2064     Perl_re_printf( aTHX_  "\n" );
2065 }
2066 /*
2067   Dumps a fully constructed but uncompressed trie in list form.
2068   List tries normally only are used for construction when the number of
2069   possible chars (trie->uniquecharcount) is very high.
2070   Used for debugging make_trie().
2071 */
2072 STATIC void
2073 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2074                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2075                          U32 depth)
2076 {
2077     U32 state;
2078     SV *sv=sv_newmortal();
2079     int colwidth= widecharmap ? 6 : 4;
2080     GET_RE_DEBUG_FLAGS_DECL;
2081
2082     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2083
2084     /* print out the table precompression.  */
2085     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2086             depth+1 );
2087     Perl_re_indentf( aTHX_  "%s",
2088             depth+1, "------:-----+-----------------\n" );
2089
2090     for( state=1 ; state < next_alloc ; state ++ ) {
2091         U16 charid;
2092
2093         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2094             depth+1, (UV)state  );
2095         if ( ! trie->states[ state ].wordnum ) {
2096             Perl_re_printf( aTHX_  "%5s| ","");
2097         } else {
2098             Perl_re_printf( aTHX_  "W%4x| ",
2099                 trie->states[ state ].wordnum
2100             );
2101         }
2102         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2103             SV ** const tmp = av_fetch( revcharmap,
2104                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2105             if ( tmp ) {
2106                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2107                     colwidth,
2108                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2109                               colwidth,
2110                               PL_colors[0], PL_colors[1],
2111                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2112                               | PERL_PV_ESCAPE_FIRSTCHAR
2113                     ) ,
2114                     TRIE_LIST_ITEM(state,charid).forid,
2115                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2116                 );
2117                 if (!(charid % 10))
2118                     Perl_re_printf( aTHX_  "\n%*s| ",
2119                         (int)((depth * 2) + 14), "");
2120             }
2121         }
2122         Perl_re_printf( aTHX_  "\n");
2123     }
2124 }
2125
2126 /*
2127   Dumps a fully constructed but uncompressed trie in table form.
2128   This is the normal DFA style state transition table, with a few
2129   twists to facilitate compression later.
2130   Used for debugging make_trie().
2131 */
2132 STATIC void
2133 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2134                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2135                           U32 depth)
2136 {
2137     U32 state;
2138     U16 charid;
2139     SV *sv=sv_newmortal();
2140     int colwidth= widecharmap ? 6 : 4;
2141     GET_RE_DEBUG_FLAGS_DECL;
2142
2143     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2144
2145     /*
2146        print out the table precompression so that we can do a visual check
2147        that they are identical.
2148      */
2149
2150     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2151
2152     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2153         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2154         if ( tmp ) {
2155             Perl_re_printf( aTHX_  "%*s",
2156                 colwidth,
2157                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2158                             PL_colors[0], PL_colors[1],
2159                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2160                             PERL_PV_ESCAPE_FIRSTCHAR
2161                 )
2162             );
2163         }
2164     }
2165
2166     Perl_re_printf( aTHX_ "\n");
2167     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2168
2169     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2170         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2171     }
2172
2173     Perl_re_printf( aTHX_  "\n" );
2174
2175     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2176
2177         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2178             depth+1,
2179             (UV)TRIE_NODENUM( state ) );
2180
2181         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2182             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2183             if (v)
2184                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2185             else
2186                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2187         }
2188         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2189             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2190                                             (UV)trie->trans[ state ].check );
2191         } else {
2192             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2193                                             (UV)trie->trans[ state ].check,
2194             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2195         }
2196     }
2197 }
2198
2199 #endif
2200
2201
2202 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2203   startbranch: the first branch in the whole branch sequence
2204   first      : start branch of sequence of branch-exact nodes.
2205                May be the same as startbranch
2206   last       : Thing following the last branch.
2207                May be the same as tail.
2208   tail       : item following the branch sequence
2209   count      : words in the sequence
2210   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2211   depth      : indent depth
2212
2213 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2214
2215 A trie is an N'ary tree where the branches are determined by digital
2216 decomposition of the key. IE, at the root node you look up the 1st character and
2217 follow that branch repeat until you find the end of the branches. Nodes can be
2218 marked as "accepting" meaning they represent a complete word. Eg:
2219
2220   /he|she|his|hers/
2221
2222 would convert into the following structure. Numbers represent states, letters
2223 following numbers represent valid transitions on the letter from that state, if
2224 the number is in square brackets it represents an accepting state, otherwise it
2225 will be in parenthesis.
2226
2227       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2228       |    |
2229       |   (2)
2230       |    |
2231      (1)   +-i->(6)-+-s->[7]
2232       |
2233       +-s->(3)-+-h->(4)-+-e->[5]
2234
2235       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2236
2237 This shows that when matching against the string 'hers' we will begin at state 1
2238 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2239 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2240 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2241 single traverse. We store a mapping from accepting to state to which word was
2242 matched, and then when we have multiple possibilities we try to complete the
2243 rest of the regex in the order in which they occurred in the alternation.
2244
2245 The only prior NFA like behaviour that would be changed by the TRIE support is
2246 the silent ignoring of duplicate alternations which are of the form:
2247
2248  / (DUPE|DUPE) X? (?{ ... }) Y /x
2249
2250 Thus EVAL blocks following a trie may be called a different number of times with
2251 and without the optimisation. With the optimisations dupes will be silently
2252 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2253 the following demonstrates:
2254
2255  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2256
2257 which prints out 'word' three times, but
2258
2259  'words'=~/(word|word|word)(?{ print $1 })S/
2260
2261 which doesnt print it out at all. This is due to other optimisations kicking in.
2262
2263 Example of what happens on a structural level:
2264
2265 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2266
2267    1: CURLYM[1] {1,32767}(18)
2268    5:   BRANCH(8)
2269    6:     EXACT <ac>(16)
2270    8:   BRANCH(11)
2271    9:     EXACT <ad>(16)
2272   11:   BRANCH(14)
2273   12:     EXACT <ab>(16)
2274   16:   SUCCEED(0)
2275   17:   NOTHING(18)
2276   18: END(0)
2277
2278 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2279 and should turn into:
2280
2281    1: CURLYM[1] {1,32767}(18)
2282    5:   TRIE(16)
2283         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2284           <ac>
2285           <ad>
2286           <ab>
2287   16:   SUCCEED(0)
2288   17:   NOTHING(18)
2289   18: END(0)
2290
2291 Cases where tail != last would be like /(?foo|bar)baz/:
2292
2293    1: BRANCH(4)
2294    2:   EXACT <foo>(8)
2295    4: BRANCH(7)
2296    5:   EXACT <bar>(8)
2297    7: TAIL(8)
2298    8: EXACT <baz>(10)
2299   10: END(0)
2300
2301 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2302 and would end up looking like:
2303
2304     1: TRIE(8)
2305       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2306         <foo>
2307         <bar>
2308    7: TAIL(8)
2309    8: EXACT <baz>(10)
2310   10: END(0)
2311
2312     d = uvchr_to_utf8_flags(d, uv, 0);
2313
2314 is the recommended Unicode-aware way of saying
2315
2316     *(d++) = uv;
2317 */
2318
2319 #define TRIE_STORE_REVCHAR(val)                                            \
2320     STMT_START {                                                           \
2321         if (UTF) {                                                         \
2322             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2323             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2324             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2325             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2326             SvPOK_on(zlopp);                                               \
2327             SvUTF8_on(zlopp);                                              \
2328             av_push(revcharmap, zlopp);                                    \
2329         } else {                                                           \
2330             char ooooff = (char)val;                                           \
2331             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2332         }                                                                  \
2333         } STMT_END
2334
2335 /* This gets the next character from the input, folding it if not already
2336  * folded. */
2337 #define TRIE_READ_CHAR STMT_START {                                           \
2338     wordlen++;                                                                \
2339     if ( UTF ) {                                                              \
2340         /* if it is UTF then it is either already folded, or does not need    \
2341          * folding */                                                         \
2342         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2343     }                                                                         \
2344     else if (folder == PL_fold_latin1) {                                      \
2345         /* This folder implies Unicode rules, which in the range expressible  \
2346          *  by not UTF is the lower case, with the two exceptions, one of     \
2347          *  which should have been taken care of before calling this */       \
2348         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2349         uvc = toLOWER_L1(*uc);                                                \
2350         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2351         len = 1;                                                              \
2352     } else {                                                                  \
2353         /* raw data, will be folded later if needed */                        \
2354         uvc = (U32)*uc;                                                       \
2355         len = 1;                                                              \
2356     }                                                                         \
2357 } STMT_END
2358
2359
2360
2361 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2362     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2363         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
2364         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2365     }                                                           \
2366     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2367     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2368     TRIE_LIST_CUR( state )++;                                   \
2369 } STMT_END
2370
2371 #define TRIE_LIST_NEW(state) STMT_START {                       \
2372     Newxz( trie->states[ state ].trans.list,               \
2373         4, reg_trie_trans_le );                                 \
2374      TRIE_LIST_CUR( state ) = 1;                                \
2375      TRIE_LIST_LEN( state ) = 4;                                \
2376 } STMT_END
2377
2378 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2379     U16 dupe= trie->states[ state ].wordnum;                    \
2380     regnode * const noper_next = regnext( noper );              \
2381                                                                 \
2382     DEBUG_r({                                                   \
2383         /* store the word for dumping */                        \
2384         SV* tmp;                                                \
2385         if (OP(noper) != NOTHING)                               \
2386             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2387         else                                                    \
2388             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2389         av_push( trie_words, tmp );                             \
2390     });                                                         \
2391                                                                 \
2392     curword++;                                                  \
2393     trie->wordinfo[curword].prev   = 0;                         \
2394     trie->wordinfo[curword].len    = wordlen;                   \
2395     trie->wordinfo[curword].accept = state;                     \
2396                                                                 \
2397     if ( noper_next < tail ) {                                  \
2398         if (!trie->jump)                                        \
2399             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2400                                                  sizeof(U16) ); \
2401         trie->jump[curword] = (U16)(noper_next - convert);      \
2402         if (!jumper)                                            \
2403             jumper = noper_next;                                \
2404         if (!nextbranch)                                        \
2405             nextbranch= regnext(cur);                           \
2406     }                                                           \
2407                                                                 \
2408     if ( dupe ) {                                               \
2409         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2410         /* chain, so that when the bits of chain are later    */\
2411         /* linked together, the dups appear in the chain      */\
2412         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2413         trie->wordinfo[dupe].prev = curword;                    \
2414     } else {                                                    \
2415         /* we haven't inserted this word yet.                */ \
2416         trie->states[ state ].wordnum = curword;                \
2417     }                                                           \
2418 } STMT_END
2419
2420
2421 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2422      ( ( base + charid >=  ucharcount                                   \
2423          && base + charid < ubound                                      \
2424          && state == trie->trans[ base - ucharcount + charid ].check    \
2425          && trie->trans[ base - ucharcount + charid ].next )            \
2426            ? trie->trans[ base - ucharcount + charid ].next             \
2427            : ( state==1 ? special : 0 )                                 \
2428       )
2429
2430 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2431 STMT_START {                                                \
2432     TRIE_BITMAP_SET(trie, uvc);                             \
2433     /* store the folded codepoint */                        \
2434     if ( folder )                                           \
2435         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2436                                                             \
2437     if ( !UTF ) {                                           \
2438         /* store first byte of utf8 representation of */    \
2439         /* variant codepoints */                            \
2440         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2441             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2442         }                                                   \
2443     }                                                       \
2444 } STMT_END
2445 #define MADE_TRIE       1
2446 #define MADE_JUMP_TRIE  2
2447 #define MADE_EXACT_TRIE 4
2448
2449 STATIC I32
2450 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2451                   regnode *first, regnode *last, regnode *tail,
2452                   U32 word_count, U32 flags, U32 depth)
2453 {
2454     /* first pass, loop through and scan words */
2455     reg_trie_data *trie;
2456     HV *widecharmap = NULL;
2457     AV *revcharmap = newAV();
2458     regnode *cur;
2459     STRLEN len = 0;
2460     UV uvc = 0;
2461     U16 curword = 0;
2462     U32 next_alloc = 0;
2463     regnode *jumper = NULL;
2464     regnode *nextbranch = NULL;
2465     regnode *convert = NULL;
2466     U32 *prev_states; /* temp array mapping each state to previous one */
2467     /* we just use folder as a flag in utf8 */
2468     const U8 * folder = NULL;
2469
2470 #ifdef DEBUGGING
2471     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2472     AV *trie_words = NULL;
2473     /* along with revcharmap, this only used during construction but both are
2474      * useful during debugging so we store them in the struct when debugging.
2475      */
2476 #else
2477     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2478     STRLEN trie_charcount=0;
2479 #endif
2480     SV *re_trie_maxbuff;
2481     GET_RE_DEBUG_FLAGS_DECL;
2482
2483     PERL_ARGS_ASSERT_MAKE_TRIE;
2484 #ifndef DEBUGGING
2485     PERL_UNUSED_ARG(depth);
2486 #endif
2487
2488     switch (flags) {
2489         case EXACT: case EXACTL: break;
2490         case EXACTFA:
2491         case EXACTFU_SS:
2492         case EXACTFU:
2493         case EXACTFLU8: folder = PL_fold_latin1; break;
2494         case EXACTF:  folder = PL_fold; break;
2495         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2496     }
2497
2498     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2499     trie->refcount = 1;
2500     trie->startstate = 1;
2501     trie->wordcount = word_count;
2502     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2503     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2504     if (flags == EXACT || flags == EXACTL)
2505         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2506     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2507                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2508
2509     DEBUG_r({
2510         trie_words = newAV();
2511     });
2512
2513     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2514     assert(re_trie_maxbuff);
2515     if (!SvIOK(re_trie_maxbuff)) {
2516         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2517     }
2518     DEBUG_TRIE_COMPILE_r({
2519         Perl_re_indentf( aTHX_
2520           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2521           depth+1,
2522           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2523           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2524     });
2525
2526    /* Find the node we are going to overwrite */
2527     if ( first == startbranch && OP( last ) != BRANCH ) {
2528         /* whole branch chain */
2529         convert = first;
2530     } else {
2531         /* branch sub-chain */
2532         convert = NEXTOPER( first );
2533     }
2534
2535     /*  -- First loop and Setup --
2536
2537        We first traverse the branches and scan each word to determine if it
2538        contains widechars, and how many unique chars there are, this is
2539        important as we have to build a table with at least as many columns as we
2540        have unique chars.
2541
2542        We use an array of integers to represent the character codes 0..255
2543        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2544        the native representation of the character value as the key and IV's for
2545        the coded index.
2546
2547        *TODO* If we keep track of how many times each character is used we can
2548        remap the columns so that the table compression later on is more
2549        efficient in terms of memory by ensuring the most common value is in the
2550        middle and the least common are on the outside.  IMO this would be better
2551        than a most to least common mapping as theres a decent chance the most
2552        common letter will share a node with the least common, meaning the node
2553        will not be compressible. With a middle is most common approach the worst
2554        case is when we have the least common nodes twice.
2555
2556      */
2557
2558     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2559         regnode *noper = NEXTOPER( cur );
2560         const U8 *uc;
2561         const U8 *e;
2562         int foldlen = 0;
2563         U32 wordlen      = 0;         /* required init */
2564         STRLEN minchars = 0;
2565         STRLEN maxchars = 0;
2566         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2567                                                bitmap?*/
2568
2569         if (OP(noper) == NOTHING) {
2570             /* skip past a NOTHING at the start of an alternation
2571              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2572              */
2573             regnode *noper_next= regnext(noper);
2574             if (noper_next < tail)
2575                 noper= noper_next;
2576         }
2577
2578         if ( noper < tail &&
2579                 (
2580                     OP(noper) == flags ||
2581                     (
2582                         flags == EXACTFU &&
2583                         OP(noper) == EXACTFU_SS
2584                     )
2585                 )
2586         ) {
2587             uc= (U8*)STRING(noper);
2588             e= uc + STR_LEN(noper);
2589         } else {
2590             trie->minlen= 0;
2591             continue;
2592         }
2593
2594
2595         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2596             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2597                                           regardless of encoding */
2598             if (OP( noper ) == EXACTFU_SS) {
2599                 /* false positives are ok, so just set this */
2600                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2601             }
2602         }
2603
2604         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2605                                            branch */
2606             TRIE_CHARCOUNT(trie)++;
2607             TRIE_READ_CHAR;
2608
2609             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2610              * is in effect.  Under /i, this character can match itself, or
2611              * anything that folds to it.  If not under /i, it can match just
2612              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2613              * all fold to k, and all are single characters.   But some folds
2614              * expand to more than one character, so for example LATIN SMALL
2615              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2616              * the string beginning at 'uc' is 'ffi', it could be matched by
2617              * three characters, or just by the one ligature character. (It
2618              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2619              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2620              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2621              * match.)  The trie needs to know the minimum and maximum number
2622              * of characters that could match so that it can use size alone to
2623              * quickly reject many match attempts.  The max is simple: it is
2624              * the number of folded characters in this branch (since a fold is
2625              * never shorter than what folds to it. */
2626
2627             maxchars++;
2628
2629             /* And the min is equal to the max if not under /i (indicated by
2630              * 'folder' being NULL), or there are no multi-character folds.  If
2631              * there is a multi-character fold, the min is incremented just
2632              * once, for the character that folds to the sequence.  Each
2633              * character in the sequence needs to be added to the list below of
2634              * characters in the trie, but we count only the first towards the
2635              * min number of characters needed.  This is done through the
2636              * variable 'foldlen', which is returned by the macros that look
2637              * for these sequences as the number of bytes the sequence
2638              * occupies.  Each time through the loop, we decrement 'foldlen' by
2639              * how many bytes the current char occupies.  Only when it reaches
2640              * 0 do we increment 'minchars' or look for another multi-character
2641              * sequence. */
2642             if (folder == NULL) {
2643                 minchars++;
2644             }
2645             else if (foldlen > 0) {
2646                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2647             }
2648             else {
2649                 minchars++;
2650
2651                 /* See if *uc is the beginning of a multi-character fold.  If
2652                  * so, we decrement the length remaining to look at, to account
2653                  * for the current character this iteration.  (We can use 'uc'
2654                  * instead of the fold returned by TRIE_READ_CHAR because for
2655                  * non-UTF, the latin1_safe macro is smart enough to account
2656                  * for all the unfolded characters, and because for UTF, the
2657                  * string will already have been folded earlier in the
2658                  * compilation process */
2659                 if (UTF) {
2660                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2661                         foldlen -= UTF8SKIP(uc);
2662                     }
2663                 }
2664                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2665                     foldlen--;
2666                 }
2667             }
2668
2669             /* The current character (and any potential folds) should be added
2670              * to the possible matching characters for this position in this
2671              * branch */
2672             if ( uvc < 256 ) {
2673                 if ( folder ) {
2674                     U8 folded= folder[ (U8) uvc ];
2675                     if ( !trie->charmap[ folded ] ) {
2676                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2677                         TRIE_STORE_REVCHAR( folded );
2678                     }
2679                 }
2680                 if ( !trie->charmap[ uvc ] ) {
2681                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2682                     TRIE_STORE_REVCHAR( uvc );
2683                 }
2684                 if ( set_bit ) {
2685                     /* store the codepoint in the bitmap, and its folded
2686                      * equivalent. */
2687                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2688                     set_bit = 0; /* We've done our bit :-) */
2689                 }
2690             } else {
2691
2692                 /* XXX We could come up with the list of code points that fold
2693                  * to this using PL_utf8_foldclosures, except not for
2694                  * multi-char folds, as there may be multiple combinations
2695                  * there that could work, which needs to wait until runtime to
2696                  * resolve (The comment about LIGATURE FFI above is such an
2697                  * example */
2698
2699                 SV** svpp;
2700                 if ( !widecharmap )
2701                     widecharmap = newHV();
2702
2703                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2704
2705                 if ( !svpp )
2706                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2707
2708                 if ( !SvTRUE( *svpp ) ) {
2709                     sv_setiv( *svpp, ++trie->uniquecharcount );
2710                     TRIE_STORE_REVCHAR(uvc);
2711                 }
2712             }
2713         } /* end loop through characters in this branch of the trie */
2714
2715         /* We take the min and max for this branch and combine to find the min
2716          * and max for all branches processed so far */
2717         if( cur == first ) {
2718             trie->minlen = minchars;
2719             trie->maxlen = maxchars;
2720         } else if (minchars < trie->minlen) {
2721             trie->minlen = minchars;
2722         } else if (maxchars > trie->maxlen) {
2723             trie->maxlen = maxchars;
2724         }
2725     } /* end first pass */
2726     DEBUG_TRIE_COMPILE_r(
2727         Perl_re_indentf( aTHX_
2728                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2729                 depth+1,
2730                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2731                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2732                 (int)trie->minlen, (int)trie->maxlen )
2733     );
2734
2735     /*
2736         We now know what we are dealing with in terms of unique chars and
2737         string sizes so we can calculate how much memory a naive
2738         representation using a flat table  will take. If it's over a reasonable
2739         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2740         conservative but potentially much slower representation using an array
2741         of lists.
2742
2743         At the end we convert both representations into the same compressed
2744         form that will be used in regexec.c for matching with. The latter
2745         is a form that cannot be used to construct with but has memory
2746         properties similar to the list form and access properties similar
2747         to the table form making it both suitable for fast searches and
2748         small enough that its feasable to store for the duration of a program.
2749
2750         See the comment in the code where the compressed table is produced
2751         inplace from the flat tabe representation for an explanation of how
2752         the compression works.
2753
2754     */
2755
2756
2757     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2758     prev_states[1] = 0;
2759
2760     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2761                                                     > SvIV(re_trie_maxbuff) )
2762     {
2763         /*
2764             Second Pass -- Array Of Lists Representation
2765
2766             Each state will be represented by a list of charid:state records
2767             (reg_trie_trans_le) the first such element holds the CUR and LEN
2768             points of the allocated array. (See defines above).
2769
2770             We build the initial structure using the lists, and then convert
2771             it into the compressed table form which allows faster lookups
2772             (but cant be modified once converted).
2773         */
2774
2775         STRLEN transcount = 1;
2776
2777         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2778             depth+1));
2779
2780         trie->states = (reg_trie_state *)
2781             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2782                                   sizeof(reg_trie_state) );
2783         TRIE_LIST_NEW(1);
2784         next_alloc = 2;
2785
2786         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2787
2788             regnode *noper   = NEXTOPER( cur );
2789             U32 state        = 1;         /* required init */
2790             U16 charid       = 0;         /* sanity init */
2791             U32 wordlen      = 0;         /* required init */
2792
2793             if (OP(noper) == NOTHING) {
2794                 regnode *noper_next= regnext(noper);
2795                 if (noper_next < tail)
2796                     noper= noper_next;
2797             }
2798
2799             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2800                 const U8 *uc= (U8*)STRING(noper);
2801                 const U8 *e= uc + STR_LEN(noper);
2802
2803                 for ( ; uc < e ; uc += len ) {
2804
2805                     TRIE_READ_CHAR;
2806
2807                     if ( uvc < 256 ) {
2808                         charid = trie->charmap[ uvc ];
2809                     } else {
2810                         SV** const svpp = hv_fetch( widecharmap,
2811                                                     (char*)&uvc,
2812                                                     sizeof( UV ),
2813                                                     0);
2814                         if ( !svpp ) {
2815                             charid = 0;
2816                         } else {
2817                             charid=(U16)SvIV( *svpp );
2818                         }
2819                     }
2820                     /* charid is now 0 if we dont know the char read, or
2821                      * nonzero if we do */
2822                     if ( charid ) {
2823
2824                         U16 check;
2825                         U32 newstate = 0;
2826
2827                         charid--;
2828                         if ( !trie->states[ state ].trans.list ) {
2829                             TRIE_LIST_NEW( state );
2830                         }
2831                         for ( check = 1;
2832                               check <= TRIE_LIST_USED( state );
2833                               check++ )
2834                         {
2835                             if ( TRIE_LIST_ITEM( state, check ).forid
2836                                                                     == charid )
2837                             {
2838                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2839                                 break;
2840                             }
2841                         }
2842                         if ( ! newstate ) {
2843                             newstate = next_alloc++;
2844                             prev_states[newstate] = state;
2845                             TRIE_LIST_PUSH( state, charid, newstate );
2846                             transcount++;
2847                         }
2848                         state = newstate;
2849                     } else {
2850                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2851                     }
2852                 }
2853             }
2854             TRIE_HANDLE_WORD(state);
2855
2856         } /* end second pass */
2857
2858         /* next alloc is the NEXT state to be allocated */
2859         trie->statecount = next_alloc;
2860         trie->states = (reg_trie_state *)
2861             PerlMemShared_realloc( trie->states,
2862                                    next_alloc
2863                                    * sizeof(reg_trie_state) );
2864
2865         /* and now dump it out before we compress it */
2866         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2867                                                          revcharmap, next_alloc,
2868                                                          depth+1)
2869         );
2870
2871         trie->trans = (reg_trie_trans *)
2872             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2873         {
2874             U32 state;
2875             U32 tp = 0;
2876             U32 zp = 0;
2877
2878
2879             for( state=1 ; state < next_alloc ; state ++ ) {
2880                 U32 base=0;
2881
2882                 /*
2883                 DEBUG_TRIE_COMPILE_MORE_r(
2884                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2885                 );
2886                 */
2887
2888                 if (trie->states[state].trans.list) {
2889                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2890                     U16 maxid=minid;
2891                     U16 idx;
2892
2893                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2894                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2895                         if ( forid < minid ) {
2896                             minid=forid;
2897                         } else if ( forid > maxid ) {
2898                             maxid=forid;
2899                         }
2900                     }
2901                     if ( transcount < tp + maxid - minid + 1) {
2902                         transcount *= 2;
2903                         trie->trans = (reg_trie_trans *)
2904                             PerlMemShared_realloc( trie->trans,
2905                                                      transcount
2906                                                      * sizeof(reg_trie_trans) );
2907                         Zero( trie->trans + (transcount / 2),
2908                               transcount / 2,
2909                               reg_trie_trans );
2910                     }
2911                     base = trie->uniquecharcount + tp - minid;
2912                     if ( maxid == minid ) {
2913                         U32 set = 0;
2914                         for ( ; zp < tp ; zp++ ) {
2915                             if ( ! trie->trans[ zp ].next ) {
2916                                 base = trie->uniquecharcount + zp - minid;
2917                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2918                                                                    1).newstate;
2919                                 trie->trans[ zp ].check = state;
2920                                 set = 1;
2921                                 break;
2922                             }
2923                         }
2924                         if ( !set ) {
2925                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2926                                                                    1).newstate;
2927                             trie->trans[ tp ].check = state;
2928                             tp++;
2929                             zp = tp;
2930                         }
2931                     } else {
2932                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2933                             const U32 tid = base
2934                                            - trie->uniquecharcount
2935                                            + TRIE_LIST_ITEM( state, idx ).forid;
2936                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2937                                                                 idx ).newstate;
2938                             trie->trans[ tid ].check = state;
2939                         }
2940                         tp += ( maxid - minid + 1 );
2941                     }
2942                     Safefree(trie->states[ state ].trans.list);
2943                 }
2944                 /*
2945                 DEBUG_TRIE_COMPILE_MORE_r(
2946                     Perl_re_printf( aTHX_  " base: %d\n",base);
2947                 );
2948                 */
2949                 trie->states[ state ].trans.base=base;
2950             }
2951             trie->lasttrans = tp + 1;
2952         }
2953     } else {
2954         /*
2955            Second Pass -- Flat Table Representation.
2956
2957            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2958            each.  We know that we will need Charcount+1 trans at most to store
2959            the data (one row per char at worst case) So we preallocate both
2960            structures assuming worst case.
2961
2962            We then construct the trie using only the .next slots of the entry
2963            structs.
2964
2965            We use the .check field of the first entry of the node temporarily
2966            to make compression both faster and easier by keeping track of how
2967            many non zero fields are in the node.
2968
2969            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2970            transition.
2971
2972            There are two terms at use here: state as a TRIE_NODEIDX() which is
2973            a number representing the first entry of the node, and state as a
2974            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2975            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2976            if there are 2 entrys per node. eg:
2977
2978              A B       A B
2979           1. 2 4    1. 3 7
2980           2. 0 3    3. 0 5
2981           3. 0 0    5. 0 0
2982           4. 0 0    7. 0 0
2983
2984            The table is internally in the right hand, idx form. However as we
2985            also have to deal with the states array which is indexed by nodenum
2986            we have to use TRIE_NODENUM() to convert.
2987
2988         */
2989         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
2990             depth+1));
2991
2992         trie->trans = (reg_trie_trans *)
2993             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2994                                   * trie->uniquecharcount + 1,
2995                                   sizeof(reg_trie_trans) );
2996         trie->states = (reg_trie_state *)
2997             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2998                                   sizeof(reg_trie_state) );
2999         next_alloc = trie->uniquecharcount + 1;
3000
3001
3002         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3003
3004             regnode *noper   = NEXTOPER( cur );
3005
3006             U32 state        = 1;         /* required init */
3007
3008             U16 charid       = 0;         /* sanity init */
3009             U32 accept_state = 0;         /* sanity init */
3010
3011             U32 wordlen      = 0;         /* required init */
3012
3013             if (OP(noper) == NOTHING) {
3014                 regnode *noper_next= regnext(noper);
3015                 if (noper_next < tail)
3016                     noper= noper_next;
3017             }
3018
3019             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3020                 const U8 *uc= (U8*)STRING(noper);
3021                 const U8 *e= uc + STR_LEN(noper);
3022
3023                 for ( ; uc < e ; uc += len ) {
3024
3025                     TRIE_READ_CHAR;
3026
3027                     if ( uvc < 256 ) {
3028                         charid = trie->charmap[ uvc ];
3029                     } else {
3030                         SV* const * const svpp = hv_fetch( widecharmap,
3031                                                            (char*)&uvc,
3032                                                            sizeof( UV ),
3033                                                            0);
3034                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3035                     }
3036                     if ( charid ) {
3037                         charid--;
3038                         if ( !trie->trans[ state + charid ].next ) {
3039                             trie->trans[ state + charid ].next = next_alloc;
3040                             trie->trans[ state ].check++;
3041                             prev_states[TRIE_NODENUM(next_alloc)]
3042                                     = TRIE_NODENUM(state);
3043                             next_alloc += trie->uniquecharcount;
3044                         }
3045                         state = trie->trans[ state + charid ].next;
3046                     } else {
3047                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3048                     }
3049                     /* charid is now 0 if we dont know the char read, or
3050                      * nonzero if we do */
3051                 }
3052             }
3053             accept_state = TRIE_NODENUM( state );
3054             TRIE_HANDLE_WORD(accept_state);
3055
3056         } /* end second pass */
3057
3058         /* and now dump it out before we compress it */
3059         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3060                                                           revcharmap,
3061                                                           next_alloc, depth+1));
3062
3063         {
3064         /*
3065            * Inplace compress the table.*
3066
3067            For sparse data sets the table constructed by the trie algorithm will
3068            be mostly 0/FAIL transitions or to put it another way mostly empty.
3069            (Note that leaf nodes will not contain any transitions.)
3070
3071            This algorithm compresses the tables by eliminating most such
3072            transitions, at the cost of a modest bit of extra work during lookup:
3073
3074            - Each states[] entry contains a .base field which indicates the
3075            index in the state[] array wheres its transition data is stored.
3076
3077            - If .base is 0 there are no valid transitions from that node.
3078
3079            - If .base is nonzero then charid is added to it to find an entry in
3080            the trans array.
3081
3082            -If trans[states[state].base+charid].check!=state then the
3083            transition is taken to be a 0/Fail transition. Thus if there are fail
3084            transitions at the front of the node then the .base offset will point
3085            somewhere inside the previous nodes data (or maybe even into a node
3086            even earlier), but the .check field determines if the transition is
3087            valid.
3088
3089            XXX - wrong maybe?
3090            The following process inplace converts the table to the compressed
3091            table: We first do not compress the root node 1,and mark all its
3092            .check pointers as 1 and set its .base pointer as 1 as well. This
3093            allows us to do a DFA construction from the compressed table later,
3094            and ensures that any .base pointers we calculate later are greater
3095            than 0.
3096
3097            - We set 'pos' to indicate the first entry of the second node.
3098
3099            - We then iterate over the columns of the node, finding the first and
3100            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3101            and set the .check pointers accordingly, and advance pos
3102            appropriately and repreat for the next node. Note that when we copy
3103            the next pointers we have to convert them from the original
3104            NODEIDX form to NODENUM form as the former is not valid post
3105            compression.
3106
3107            - If a node has no transitions used we mark its base as 0 and do not
3108            advance the pos pointer.
3109
3110            - If a node only has one transition we use a second pointer into the
3111            structure to fill in allocated fail transitions from other states.
3112            This pointer is independent of the main pointer and scans forward
3113            looking for null transitions that are allocated to a state. When it
3114            finds one it writes the single transition into the "hole".  If the
3115            pointer doesnt find one the single transition is appended as normal.
3116
3117            - Once compressed we can Renew/realloc the structures to release the
3118            excess space.
3119
3120            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3121            specifically Fig 3.47 and the associated pseudocode.
3122
3123            demq
3124         */
3125         const U32 laststate = TRIE_NODENUM( next_alloc );
3126         U32 state, charid;
3127         U32 pos = 0, zp=0;
3128         trie->statecount = laststate;
3129
3130         for ( state = 1 ; state < laststate ; state++ ) {
3131             U8 flag = 0;
3132             const U32 stateidx = TRIE_NODEIDX( state );
3133             const U32 o_used = trie->trans[ stateidx ].check;
3134             U32 used = trie->trans[ stateidx ].check;
3135             trie->trans[ stateidx ].check = 0;
3136
3137             for ( charid = 0;
3138                   used && charid < trie->uniquecharcount;
3139                   charid++ )
3140             {
3141                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3142                     if ( trie->trans[ stateidx + charid ].next ) {
3143                         if (o_used == 1) {
3144                             for ( ; zp < pos ; zp++ ) {
3145                                 if ( ! trie->trans[ zp ].next ) {
3146                                     break;
3147                                 }
3148                             }
3149                             trie->states[ state ].trans.base
3150                                                     = zp
3151                                                       + trie->uniquecharcount
3152                                                       - charid ;
3153                             trie->trans[ zp ].next
3154                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3155                                                              + charid ].next );
3156                             trie->trans[ zp ].check = state;
3157                             if ( ++zp > pos ) pos = zp;
3158                             break;
3159                         }
3160                         used--;
3161                     }
3162                     if ( !flag ) {
3163                         flag = 1;
3164                         trie->states[ state ].trans.base
3165                                        = pos + trie->uniquecharcount - charid ;
3166                     }
3167                     trie->trans[ pos ].next
3168                         = SAFE_TRIE_NODENUM(
3169                                        trie->trans[ stateidx + charid ].next );
3170                     trie->trans[ pos ].check = state;
3171                     pos++;
3172                 }
3173             }
3174         }
3175         trie->lasttrans = pos + 1;
3176         trie->states = (reg_trie_state *)
3177             PerlMemShared_realloc( trie->states, laststate
3178                                    * sizeof(reg_trie_state) );
3179         DEBUG_TRIE_COMPILE_MORE_r(
3180             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3181                 depth+1,
3182                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3183                        + 1 ),
3184                 (IV)next_alloc,
3185                 (IV)pos,
3186                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3187             );
3188
3189         } /* end table compress */
3190     }
3191     DEBUG_TRIE_COMPILE_MORE_r(
3192             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3193                 depth+1,
3194                 (UV)trie->statecount,
3195                 (UV)trie->lasttrans)
3196     );
3197     /* resize the trans array to remove unused space */
3198     trie->trans = (reg_trie_trans *)
3199         PerlMemShared_realloc( trie->trans, trie->lasttrans
3200                                * sizeof(reg_trie_trans) );
3201
3202     {   /* Modify the program and insert the new TRIE node */
3203         U8 nodetype =(U8)(flags & 0xFF);
3204         char *str=NULL;
3205
3206 #ifdef DEBUGGING
3207         regnode *optimize = NULL;
3208 #ifdef RE_TRACK_PATTERN_OFFSETS
3209
3210         U32 mjd_offset = 0;
3211         U32 mjd_nodelen = 0;
3212 #endif /* RE_TRACK_PATTERN_OFFSETS */
3213 #endif /* DEBUGGING */
3214         /*
3215            This means we convert either the first branch or the first Exact,
3216            depending on whether the thing following (in 'last') is a branch
3217            or not and whther first is the startbranch (ie is it a sub part of
3218            the alternation or is it the whole thing.)
3219            Assuming its a sub part we convert the EXACT otherwise we convert
3220            the whole branch sequence, including the first.
3221          */
3222         /* Find the node we are going to overwrite */
3223         if ( first != startbranch || OP( last ) == BRANCH ) {
3224             /* branch sub-chain */
3225             NEXT_OFF( first ) = (U16)(last - first);
3226 #ifdef RE_TRACK_PATTERN_OFFSETS
3227             DEBUG_r({
3228                 mjd_offset= Node_Offset((convert));
3229                 mjd_nodelen= Node_Length((convert));
3230             });
3231 #endif
3232             /* whole branch chain */
3233         }
3234 #ifdef RE_TRACK_PATTERN_OFFSETS
3235         else {
3236             DEBUG_r({
3237                 const  regnode *nop = NEXTOPER( convert );
3238                 mjd_offset= Node_Offset((nop));
3239                 mjd_nodelen= Node_Length((nop));
3240             });
3241         }
3242         DEBUG_OPTIMISE_r(
3243             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3244                 depth+1,
3245                 (UV)mjd_offset, (UV)mjd_nodelen)
3246         );
3247 #endif
3248         /* But first we check to see if there is a common prefix we can
3249            split out as an EXACT and put in front of the TRIE node.  */
3250         trie->startstate= 1;
3251         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3252             /* we want to find the first state that has more than
3253              * one transition, if that state is not the first state
3254              * then we have a common prefix which we can remove.
3255              */
3256             U32 state;
3257             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3258                 U32 ofs = 0;
3259                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3260                                        transition, -1 means none */
3261                 U32 count = 0;
3262                 const U32 base = trie->states[ state ].trans.base;
3263
3264                 /* does this state terminate an alternation? */
3265                 if ( trie->states[state].wordnum )
3266                         count = 1;
3267
3268                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3269                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3270                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3271                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3272                     {
3273                         if ( ++count > 1 ) {
3274                             /* we have more than one transition */
3275                             SV **tmp;
3276                             U8 *ch;
3277                             /* if this is the first state there is no common prefix
3278                              * to extract, so we can exit */
3279                             if ( state == 1 ) break;
3280                             tmp = av_fetch( revcharmap, ofs, 0);
3281                             ch = (U8*)SvPV_nolen_const( *tmp );
3282
3283                             /* if we are on count 2 then we need to initialize the
3284                              * bitmap, and store the previous char if there was one
3285                              * in it*/
3286                             if ( count == 2 ) {
3287                                 /* clear the bitmap */
3288                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3289                                 DEBUG_OPTIMISE_r(
3290                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3291                                         depth+1,
3292                                         (UV)state));
3293                                 if (first_ofs >= 0) {
3294                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3295                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3296
3297                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3298                                     DEBUG_OPTIMISE_r(
3299                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3300                                     );
3301                                 }
3302                             }
3303                             /* store the current firstchar in the bitmap */
3304                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3305                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3306                         }
3307                         first_ofs = ofs;
3308                     }
3309                 }
3310                 if ( count == 1 ) {
3311                     /* This state has only one transition, its transition is part
3312                      * of a common prefix - we need to concatenate the char it
3313                      * represents to what we have so far. */
3314                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3315                     STRLEN len;
3316                     char *ch = SvPV( *tmp, len );
3317                     DEBUG_OPTIMISE_r({
3318                         SV *sv=sv_newmortal();
3319                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3320                             depth+1,
3321                             (UV)state, (UV)first_ofs,
3322                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3323                                 PL_colors[0], PL_colors[1],
3324                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3325                                 PERL_PV_ESCAPE_FIRSTCHAR
3326                             )
3327                         );
3328                     });
3329                     if ( state==1 ) {
3330                         OP( convert ) = nodetype;
3331                         str=STRING(convert);
3332                         STR_LEN(convert)=0;
3333                     }
3334                     STR_LEN(convert) += len;
3335                     while (len--)
3336                         *str++ = *ch++;
3337                 } else {
3338 #ifdef DEBUGGING
3339                     if (state>1)
3340                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3341 #endif
3342                     break;
3343                 }
3344             }
3345             trie->prefixlen = (state-1);
3346             if (str) {
3347                 regnode *n = convert+NODE_SZ_STR(convert);
3348                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3349                 trie->startstate = state;
3350                 trie->minlen -= (state - 1);
3351                 trie->maxlen -= (state - 1);
3352 #ifdef DEBUGGING
3353                /* At least the UNICOS C compiler choked on this
3354                 * being argument to DEBUG_r(), so let's just have
3355                 * it right here. */
3356                if (
3357 #ifdef PERL_EXT_RE_BUILD
3358                    1
3359 #else
3360                    DEBUG_r_TEST
3361 #endif
3362                    ) {
3363                    regnode *fix = convert;
3364                    U32 word = trie->wordcount;
3365                    mjd_nodelen++;
3366                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3367                    while( ++fix < n ) {
3368                        Set_Node_Offset_Length(fix, 0, 0);
3369                    }
3370                    while (word--) {
3371                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3372                        if (tmp) {
3373                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3374                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3375                            else
3376                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3377                        }
3378                    }
3379                }
3380 #endif
3381                 if (trie->maxlen) {
3382                     convert = n;
3383                 } else {
3384                     NEXT_OFF(convert) = (U16)(tail - convert);
3385                     DEBUG_r(optimize= n);
3386                 }
3387             }
3388         }
3389         if (!jumper)
3390             jumper = last;
3391         if ( trie->maxlen ) {
3392             NEXT_OFF( convert ) = (U16)(tail - convert);
3393             ARG_SET( convert, data_slot );
3394             /* Store the offset to the first unabsorbed branch in
3395                jump[0], which is otherwise unused by the jump logic.
3396                We use this when dumping a trie and during optimisation. */
3397             if (trie->jump)
3398                 trie->jump[0] = (U16)(nextbranch - convert);
3399
3400             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3401              *   and there is a bitmap
3402              *   and the first "jump target" node we found leaves enough room
3403              * then convert the TRIE node into a TRIEC node, with the bitmap
3404              * embedded inline in the opcode - this is hypothetically faster.
3405              */
3406             if ( !trie->states[trie->startstate].wordnum
3407                  && trie->bitmap
3408                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3409             {
3410                 OP( convert ) = TRIEC;
3411                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3412                 PerlMemShared_free(trie->bitmap);
3413                 trie->bitmap= NULL;
3414             } else
3415                 OP( convert ) = TRIE;
3416
3417             /* store the type in the flags */
3418             convert->flags = nodetype;
3419             DEBUG_r({
3420             optimize = convert
3421                       + NODE_STEP_REGNODE
3422                       + regarglen[ OP( convert ) ];
3423             });
3424             /* XXX We really should free up the resource in trie now,
3425                    as we won't use them - (which resources?) dmq */
3426         }
3427         /* needed for dumping*/
3428         DEBUG_r(if (optimize) {
3429             regnode *opt = convert;
3430
3431             while ( ++opt < optimize) {
3432                 Set_Node_Offset_Length(opt,0,0);
3433             }
3434             /*
3435                 Try to clean up some of the debris left after the
3436                 optimisation.
3437              */
3438             while( optimize < jumper ) {
3439                 mjd_nodelen += Node_Length((optimize));
3440                 OP( optimize ) = OPTIMIZED;
3441                 Set_Node_Offset_Length(optimize,0,0);
3442                 optimize++;
3443             }
3444             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3445         });
3446     } /* end node insert */
3447
3448     /*  Finish populating the prev field of the wordinfo array.  Walk back
3449      *  from each accept state until we find another accept state, and if
3450      *  so, point the first word's .prev field at the second word. If the
3451      *  second already has a .prev field set, stop now. This will be the
3452      *  case either if we've already processed that word's accept state,
3453      *  or that state had multiple words, and the overspill words were
3454      *  already linked up earlier.
3455      */
3456     {
3457         U16 word;
3458         U32 state;
3459         U16 prev;
3460
3461         for (word=1; word <= trie->wordcount; word++) {
3462             prev = 0;
3463             if (trie->wordinfo[word].prev)
3464                 continue;
3465             state = trie->wordinfo[word].accept;
3466             while (state) {
3467                 state = prev_states[state];
3468                 if (!state)
3469                     break;
3470                 prev = trie->states[state].wordnum;
3471                 if (prev)
3472                     break;
3473             }
3474             trie->wordinfo[word].prev = prev;
3475         }
3476         Safefree(prev_states);
3477     }
3478
3479
3480     /* and now dump out the compressed format */
3481     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3482
3483     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3484 #ifdef DEBUGGING
3485     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3486     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3487 #else
3488     SvREFCNT_dec_NN(revcharmap);
3489 #endif
3490     return trie->jump
3491            ? MADE_JUMP_TRIE
3492            : trie->startstate>1
3493              ? MADE_EXACT_TRIE
3494              : MADE_TRIE;
3495 }
3496
3497 STATIC regnode *
3498 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3499 {
3500 /* The Trie is constructed and compressed now so we can build a fail array if
3501  * it's needed
3502
3503    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3504    3.32 in the
3505    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3506    Ullman 1985/88
3507    ISBN 0-201-10088-6
3508
3509    We find the fail state for each state in the trie, this state is the longest
3510    proper suffix of the current state's 'word' that is also a proper prefix of
3511    another word in our trie. State 1 represents the word '' and is thus the
3512    default fail state. This allows the DFA not to have to restart after its
3513    tried and failed a word at a given point, it simply continues as though it
3514    had been matching the other word in the first place.
3515    Consider
3516       'abcdgu'=~/abcdefg|cdgu/
3517    When we get to 'd' we are still matching the first word, we would encounter
3518    'g' which would fail, which would bring us to the state representing 'd' in
3519    the second word where we would try 'g' and succeed, proceeding to match
3520    'cdgu'.
3521  */
3522  /* add a fail transition */
3523     const U32 trie_offset = ARG(source);
3524     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3525     U32 *q;
3526     const U32 ucharcount = trie->uniquecharcount;
3527     const U32 numstates = trie->statecount;
3528     const U32 ubound = trie->lasttrans + ucharcount;
3529     U32 q_read = 0;
3530     U32 q_write = 0;
3531     U32 charid;
3532     U32 base = trie->states[ 1 ].trans.base;
3533     U32 *fail;
3534     reg_ac_data *aho;
3535     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3536     regnode *stclass;
3537     GET_RE_DEBUG_FLAGS_DECL;
3538
3539     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3540     PERL_UNUSED_CONTEXT;
3541 #ifndef DEBUGGING
3542     PERL_UNUSED_ARG(depth);
3543 #endif
3544
3545     if ( OP(source) == TRIE ) {
3546         struct regnode_1 *op = (struct regnode_1 *)
3547             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3548         StructCopy(source,op,struct regnode_1);
3549         stclass = (regnode *)op;
3550     } else {
3551         struct regnode_charclass *op = (struct regnode_charclass *)
3552             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3553         StructCopy(source,op,struct regnode_charclass);
3554         stclass = (regnode *)op;
3555     }
3556     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3557
3558     ARG_SET( stclass, data_slot );
3559     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3560     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3561     aho->trie=trie_offset;
3562     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3563     Copy( trie->states, aho->states, numstates, reg_trie_state );
3564     Newxz( q, numstates, U32);
3565     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3566     aho->refcount = 1;
3567     fail = aho->fail;
3568     /* initialize fail[0..1] to be 1 so that we always have
3569        a valid final fail state */
3570     fail[ 0 ] = fail[ 1 ] = 1;
3571
3572     for ( charid = 0; charid < ucharcount ; charid++ ) {
3573         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3574         if ( newstate ) {
3575             q[ q_write ] = newstate;
3576             /* set to point at the root */
3577             fail[ q[ q_write++ ] ]=1;
3578         }
3579     }
3580     while ( q_read < q_write) {
3581         const U32 cur = q[ q_read++ % numstates ];
3582         base = trie->states[ cur ].trans.base;
3583
3584         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3585             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3586             if (ch_state) {
3587                 U32 fail_state = cur;
3588                 U32 fail_base;
3589                 do {
3590                     fail_state = fail[ fail_state ];
3591                     fail_base = aho->states[ fail_state ].trans.base;
3592                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3593
3594                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3595                 fail[ ch_state ] = fail_state;
3596                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3597                 {
3598                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3599                 }
3600                 q[ q_write++ % numstates] = ch_state;
3601             }
3602         }
3603     }
3604     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3605        when we fail in state 1, this allows us to use the
3606        charclass scan to find a valid start char. This is based on the principle
3607        that theres a good chance the string being searched contains lots of stuff
3608        that cant be a start char.
3609      */
3610     fail[ 0 ] = fail[ 1 ] = 0;
3611     DEBUG_TRIE_COMPILE_r({
3612         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3613                       depth, (UV)numstates
3614         );
3615         for( q_read=1; q_read<numstates; q_read++ ) {
3616             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3617         }
3618         Perl_re_printf( aTHX_  "\n");
3619     });
3620     Safefree(q);
3621     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3622     return stclass;
3623 }
3624
3625
3626 #define DEBUG_PEEP(str,scan,depth)         \
3627     DEBUG_OPTIMISE_r({if (scan){           \
3628        regnode *Next = regnext(scan);      \
3629        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);\
3630        Perl_re_indentf( aTHX_  "" str ">%3d: %s (%d)", \
3631            depth, REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3632            Next ? (REG_NODE_NUM(Next)) : 0 );\
3633        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3634        Perl_re_printf( aTHX_  "\n");                   \
3635    }});
3636
3637 /* The below joins as many adjacent EXACTish nodes as possible into a single
3638  * one.  The regop may be changed if the node(s) contain certain sequences that
3639  * require special handling.  The joining is only done if:
3640  * 1) there is room in the current conglomerated node to entirely contain the
3641  *    next one.
3642  * 2) they are the exact same node type
3643  *
3644  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3645  * these get optimized out
3646  *
3647  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3648  * as possible, even if that means splitting an existing node so that its first
3649  * part is moved to the preceeding node.  This would maximise the efficiency of
3650  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3651  * EXACTFish nodes into portions that don't change under folding vs those that
3652  * do.  Those portions that don't change may be the only things in the pattern that
3653  * could be used to find fixed and floating strings.
3654  *
3655  * If a node is to match under /i (folded), the number of characters it matches
3656  * can be different than its character length if it contains a multi-character
3657  * fold.  *min_subtract is set to the total delta number of characters of the
3658  * input nodes.
3659  *
3660  * And *unfolded_multi_char is set to indicate whether or not the node contains
3661  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3662  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3663  * SMALL LETTER SHARP S, as only if the target string being matched against
3664  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3665  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3666  * whose components are all above the Latin1 range are not run-time locale
3667  * dependent, and have already been folded by the time this function is
3668  * called.)
3669  *
3670  * This is as good a place as any to discuss the design of handling these
3671  * multi-character fold sequences.  It's been wrong in Perl for a very long
3672  * time.  There are three code points in Unicode whose multi-character folds
3673  * were long ago discovered to mess things up.  The previous designs for
3674  * dealing with these involved assigning a special node for them.  This
3675  * approach doesn't always work, as evidenced by this example:
3676  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3677  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3678  * would match just the \xDF, it won't be able to handle the case where a
3679  * successful match would have to cross the node's boundary.  The new approach
3680  * that hopefully generally solves the problem generates an EXACTFU_SS node
3681  * that is "sss" in this case.
3682  *
3683  * It turns out that there are problems with all multi-character folds, and not
3684  * just these three.  Now the code is general, for all such cases.  The
3685  * approach taken is:
3686  * 1)   This routine examines each EXACTFish node that could contain multi-
3687  *      character folded sequences.  Since a single character can fold into
3688  *      such a sequence, the minimum match length for this node is less than
3689  *      the number of characters in the node.  This routine returns in
3690  *      *min_subtract how many characters to subtract from the the actual
3691  *      length of the string to get a real minimum match length; it is 0 if
3692  *      there are no multi-char foldeds.  This delta is used by the caller to
3693  *      adjust the min length of the match, and the delta between min and max,
3694  *      so that the optimizer doesn't reject these possibilities based on size
3695  *      constraints.
3696  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3697  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3698  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3699  *      there is a possible fold length change.  That means that a regular
3700  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3701  *      with length changes, and so can be processed faster.  regexec.c takes
3702  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3703  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3704  *      known until runtime).  This saves effort in regex matching.  However,
3705  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3706  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3707  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3708  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3709  *      possibilities for the non-UTF8 patterns are quite simple, except for
3710  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3711  *      members of a fold-pair, and arrays are set up for all of them so that
3712  *      the other member of the pair can be found quickly.  Code elsewhere in
3713  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3714  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3715  *      described in the next item.
3716  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3717  *      validity of the fold won't be known until runtime, and so must remain
3718  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3719  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3720  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3721  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3722  *      The reason this is a problem is that the optimizer part of regexec.c
3723  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3724  *      that a character in the pattern corresponds to at most a single
3725  *      character in the target string.  (And I do mean character, and not byte
3726  *      here, unlike other parts of the documentation that have never been
3727  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3728  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3729  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3730  *      nodes, violate the assumption, and they are the only instances where it
3731  *      is violated.  I'm reluctant to try to change the assumption, as the
3732  *      code involved is impenetrable to me (khw), so instead the code here
3733  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3734  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3735  *      boolean indicating whether or not the node contains such a fold.  When
3736  *      it is true, the caller sets a flag that later causes the optimizer in
3737  *      this file to not set values for the floating and fixed string lengths,
3738  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3739  *      assumption.  Thus, there is no optimization based on string lengths for
3740  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3741  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3742  *      assumption is wrong only in these cases is that all other non-UTF-8
3743  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3744  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3745  *      EXACTF nodes because we don't know at compile time if it actually
3746  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3747  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3748  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3749  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3750  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3751  *      string would require the pattern to be forced into UTF-8, the overhead
3752  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3753  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3754  *      locale.)
3755  *
3756  *      Similarly, the code that generates tries doesn't currently handle
3757  *      not-already-folded multi-char folds, and it looks like a pain to change
3758  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3759  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3760  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3761  *      using /iaa matching will be doing so almost entirely with ASCII
3762  *      strings, so this should rarely be encountered in practice */
3763
3764 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3765     if (PL_regkind[OP(scan)] == EXACT) \
3766         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3767
3768 STATIC U32
3769 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3770                    UV *min_subtract, bool *unfolded_multi_char,
3771                    U32 flags,regnode *val, U32 depth)
3772 {
3773     /* Merge several consecutive EXACTish nodes into one. */
3774     regnode *n = regnext(scan);
3775     U32 stringok = 1;
3776     regnode *next = scan + NODE_SZ_STR(scan);
3777     U32 merged = 0;
3778     U32 stopnow = 0;
3779 #ifdef DEBUGGING
3780     regnode *stop = scan;
3781     GET_RE_DEBUG_FLAGS_DECL;
3782 #else
3783     PERL_UNUSED_ARG(depth);
3784 #endif
3785
3786     PERL_ARGS_ASSERT_JOIN_EXACT;
3787 #ifndef EXPERIMENTAL_INPLACESCAN
3788     PERL_UNUSED_ARG(flags);
3789     PERL_UNUSED_ARG(val);
3790 #endif
3791     DEBUG_PEEP("join",scan,depth);
3792
3793     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3794      * EXACT ones that are mergeable to the current one. */
3795     while (n
3796            && (PL_regkind[OP(n)] == NOTHING
3797                || (stringok && OP(n) == OP(scan)))
3798            && NEXT_OFF(n)
3799            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3800     {
3801
3802         if (OP(n) == TAIL || n > next)
3803             stringok = 0;
3804         if (PL_regkind[OP(n)] == NOTHING) {
3805             DEBUG_PEEP("skip:",n,depth);
3806             NEXT_OFF(scan) += NEXT_OFF(n);
3807             next = n + NODE_STEP_REGNODE;
3808 #ifdef DEBUGGING
3809             if (stringok)
3810                 stop = n;
3811 #endif
3812             n = regnext(n);
3813         }
3814         else if (stringok) {
3815             const unsigned int oldl = STR_LEN(scan);
3816             regnode * const nnext = regnext(n);
3817
3818             /* XXX I (khw) kind of doubt that this works on platforms (should
3819              * Perl ever run on one) where U8_MAX is above 255 because of lots
3820              * of other assumptions */
3821             /* Don't join if the sum can't fit into a single node */
3822             if (oldl + STR_LEN(n) > U8_MAX)
3823                 break;
3824
3825             DEBUG_PEEP("merg",n,depth);
3826             merged++;
3827
3828             NEXT_OFF(scan) += NEXT_OFF(n);
3829             STR_LEN(scan) += STR_LEN(n);
3830             next = n + NODE_SZ_STR(n);
3831             /* Now we can overwrite *n : */
3832             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3833 #ifdef DEBUGGING
3834             stop = next - 1;
3835 #endif
3836             n = nnext;
3837             if (stopnow) break;
3838         }
3839
3840 #ifdef EXPERIMENTAL_INPLACESCAN
3841         if (flags && !NEXT_OFF(n)) {
3842             DEBUG_PEEP("atch", val, depth);
3843             if (reg_off_by_arg[OP(n)]) {
3844                 ARG_SET(n, val - n);
3845             }
3846             else {
3847                 NEXT_OFF(n) = val - n;
3848             }
3849             stopnow = 1;
3850         }
3851 #endif
3852     }
3853
3854     *min_subtract = 0;
3855     *unfolded_multi_char = FALSE;
3856
3857     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3858      * can now analyze for sequences of problematic code points.  (Prior to
3859      * this final joining, sequences could have been split over boundaries, and
3860      * hence missed).  The sequences only happen in folding, hence for any
3861      * non-EXACT EXACTish node */
3862     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3863         U8* s0 = (U8*) STRING(scan);
3864         U8* s = s0;
3865         U8* s_end = s0 + STR_LEN(scan);
3866
3867         int total_count_delta = 0;  /* Total delta number of characters that
3868                                        multi-char folds expand to */
3869
3870         /* One pass is made over the node's string looking for all the
3871          * possibilities.  To avoid some tests in the loop, there are two main
3872          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3873          * non-UTF-8 */
3874         if (UTF) {
3875             U8* folded = NULL;
3876
3877             if (OP(scan) == EXACTFL) {
3878                 U8 *d;
3879
3880                 /* An EXACTFL node would already have been changed to another
3881                  * node type unless there is at least one character in it that
3882                  * is problematic; likely a character whose fold definition
3883                  * won't be known until runtime, and so has yet to be folded.
3884                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3885                  * to handle the UTF-8 case, we need to create a temporary
3886                  * folded copy using UTF-8 locale rules in order to analyze it.
3887                  * This is because our macros that look to see if a sequence is
3888                  * a multi-char fold assume everything is folded (otherwise the
3889                  * tests in those macros would be too complicated and slow).
3890                  * Note that here, the non-problematic folds will have already
3891                  * been done, so we can just copy such characters.  We actually
3892                  * don't completely fold the EXACTFL string.  We skip the
3893                  * unfolded multi-char folds, as that would just create work
3894                  * below to figure out the size they already are */
3895
3896                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3897                 d = folded;
3898                 while (s < s_end) {
3899                     STRLEN s_len = UTF8SKIP(s);
3900                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3901                         Copy(s, d, s_len, U8);
3902                         d += s_len;
3903                     }
3904                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3905                         *unfolded_multi_char = TRUE;
3906                         Copy(s, d, s_len, U8);
3907                         d += s_len;
3908                     }
3909                     else if (isASCII(*s)) {
3910                         *(d++) = toFOLD(*s);
3911                     }
3912                     else {
3913                         STRLEN len;
3914                         _to_utf8_fold_flags(s, d, &len, FOLD_FLAGS_FULL);
3915                         d += len;
3916                     }
3917                     s += s_len;
3918                 }
3919
3920                 /* Point the remainder of the routine to look at our temporary
3921                  * folded copy */
3922                 s = folded;
3923                 s_end = d;
3924             } /* End of creating folded copy of EXACTFL string */
3925
3926             /* Examine the string for a multi-character fold sequence.  UTF-8
3927              * patterns have all characters pre-folded by the time this code is
3928              * executed */
3929             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3930                                      length sequence we are looking for is 2 */
3931             {
3932                 int count = 0;  /* How many characters in a multi-char fold */
3933                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3934                 if (! len) {    /* Not a multi-char fold: get next char */
3935                     s += UTF8SKIP(s);
3936                     continue;
3937                 }
3938
3939                 /* Nodes with 'ss' require special handling, except for
3940                  * EXACTFA-ish for which there is no multi-char fold to this */
3941                 if (len == 2 && *s == 's' && *(s+1) == 's'
3942                     && OP(scan) != EXACTFA
3943                     && OP(scan) != EXACTFA_NO_TRIE)
3944                 {
3945                     count = 2;
3946                     if (OP(scan) != EXACTFL) {
3947                         OP(scan) = EXACTFU_SS;
3948                     }
3949                     s += 2;
3950                 }
3951                 else { /* Here is a generic multi-char fold. */
3952                     U8* multi_end  = s + len;
3953
3954                     /* Count how many characters are in it.  In the case of
3955                      * /aa, no folds which contain ASCII code points are
3956                      * allowed, so check for those, and skip if found. */
3957                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3958                         count = utf8_length(s, multi_end);
3959                         s = multi_end;
3960                     }
3961                     else {
3962                         while (s < multi_end) {
3963                             if (isASCII(*s)) {
3964                                 s++;
3965                                 goto next_iteration;
3966                             }
3967                             else {
3968                                 s += UTF8SKIP(s);
3969                             }
3970                             count++;
3971                         }
3972                     }
3973                 }
3974
3975                 /* The delta is how long the sequence is minus 1 (1 is how long
3976                  * the character that folds to the sequence is) */
3977                 total_count_delta += count - 1;
3978               next_iteration: ;
3979             }
3980
3981             /* We created a temporary folded copy of the string in EXACTFL
3982              * nodes.  Therefore we need to be sure it doesn't go below zero,
3983              * as the real string could be shorter */
3984             if (OP(scan) == EXACTFL) {
3985                 int total_chars = utf8_length((U8*) STRING(scan),
3986                                            (U8*) STRING(scan) + STR_LEN(scan));
3987                 if (total_count_delta > total_chars) {
3988                     total_count_delta = total_chars;
3989                 }
3990             }
3991
3992             *min_subtract += total_count_delta;
3993             Safefree(folded);
3994         }
3995         else if (OP(scan) == EXACTFA) {
3996
3997             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3998              * fold to the ASCII range (and there are no existing ones in the
3999              * upper latin1 range).  But, as outlined in the comments preceding
4000              * this function, we need to flag any occurrences of the sharp s.
4001              * This character forbids trie formation (because of added
4002              * complexity) */
4003 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4004    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4005                                       || UNICODE_DOT_DOT_VERSION > 0)
4006             while (s < s_end) {
4007                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4008                     OP(scan) = EXACTFA_NO_TRIE;
4009                     *unfolded_multi_char = TRUE;
4010                     break;
4011                 }
4012                 s++;
4013             }
4014         }
4015         else {
4016
4017             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
4018              * folds that are all Latin1.  As explained in the comments
4019              * preceding this function, we look also for the sharp s in EXACTF
4020              * and EXACTFL nodes; it can be in the final position.  Otherwise
4021              * we can stop looking 1 byte earlier because have to find at least
4022              * two characters for a multi-fold */
4023             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4024                               ? s_end
4025                               : s_end -1;
4026
4027             while (s < upper) {
4028                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4029                 if (! len) {    /* Not a multi-char fold. */
4030                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4031                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4032                     {
4033                         *unfolded_multi_char = TRUE;
4034                     }
4035                     s++;
4036                     continue;
4037                 }
4038
4039                 if (len == 2
4040                     && isALPHA_FOLD_EQ(*s, 's')
4041                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4042                 {
4043
4044                     /* EXACTF nodes need to know that the minimum length
4045                      * changed so that a sharp s in the string can match this
4046                      * ss in the pattern, but they remain EXACTF nodes, as they
4047                      * won't match this unless the target string is is UTF-8,
4048                      * which we don't know until runtime.  EXACTFL nodes can't
4049                      * transform into EXACTFU nodes */
4050                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4051                         OP(scan) = EXACTFU_SS;
4052                     }
4053                 }
4054
4055                 *min_subtract += len - 1;
4056                 s += len;
4057             }
4058 #endif
4059         }
4060     }
4061
4062 #ifdef DEBUGGING
4063     /* Allow dumping but overwriting the collection of skipped
4064      * ops and/or strings with fake optimized ops */
4065     n = scan + NODE_SZ_STR(scan);
4066     while (n <= stop) {
4067         OP(n) = OPTIMIZED;
4068         FLAGS(n) = 0;
4069         NEXT_OFF(n) = 0;
4070         n++;
4071     }
4072 #endif
4073     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
4074     return stopnow;
4075 }
4076
4077 /* REx optimizer.  Converts nodes into quicker variants "in place".
4078    Finds fixed substrings.  */
4079
4080 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4081    to the position after last scanned or to NULL. */
4082
4083 #define INIT_AND_WITHP \
4084     assert(!and_withp); \
4085     Newx(and_withp,1, regnode_ssc); \
4086     SAVEFREEPV(and_withp)
4087
4088
4089 static void
4090 S_unwind_scan_frames(pTHX_ const void *p)
4091 {
4092     scan_frame *f= (scan_frame *)p;
4093     do {
4094         scan_frame *n= f->next_frame;
4095         Safefree(f);
4096         f= n;
4097     } while (f);
4098 }
4099
4100
4101 STATIC SSize_t
4102 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4103                         SSize_t *minlenp, SSize_t *deltap,
4104                         regnode *last,
4105                         scan_data_t *data,
4106                         I32 stopparen,
4107                         U32 recursed_depth,
4108                         regnode_ssc *and_withp,
4109                         U32 flags, U32 depth)
4110                         /* scanp: Start here (read-write). */
4111                         /* deltap: Write maxlen-minlen here. */
4112                         /* last: Stop before this one. */
4113                         /* data: string data about the pattern */
4114                         /* stopparen: treat close N as END */
4115                         /* recursed: which subroutines have we recursed into */
4116                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4117 {
4118     /* There must be at least this number of characters to match */
4119     SSize_t min = 0;
4120     I32 pars = 0, code;
4121     regnode *scan = *scanp, *next;
4122     SSize_t delta = 0;
4123     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4124     int is_inf_internal = 0;            /* The studied chunk is infinite */
4125     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4126     scan_data_t data_fake;
4127     SV *re_trie_maxbuff = NULL;
4128     regnode *first_non_open = scan;
4129     SSize_t stopmin = SSize_t_MAX;
4130     scan_frame *frame = NULL;
4131     GET_RE_DEBUG_FLAGS_DECL;
4132
4133     PERL_ARGS_ASSERT_STUDY_CHUNK;
4134     RExC_study_started= 1;
4135
4136
4137     if ( depth == 0 ) {
4138         while (first_non_open && OP(first_non_open) == OPEN)
4139             first_non_open=regnext(first_non_open);
4140     }
4141
4142
4143   fake_study_recurse:
4144     DEBUG_r(
4145         RExC_study_chunk_recursed_count++;
4146     );
4147     DEBUG_OPTIMISE_MORE_r(
4148     {
4149         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4150             depth, (long)stopparen,
4151             (unsigned long)RExC_study_chunk_recursed_count,
4152             (unsigned long)depth, (unsigned long)recursed_depth,
4153             scan,
4154             last);
4155         if (recursed_depth) {
4156             U32 i;
4157             U32 j;
4158             for ( j = 0 ; j < recursed_depth ; j++ ) {
4159                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4160                     if (
4161                         PAREN_TEST(RExC_study_chunk_recursed +
4162                                    ( j * RExC_study_chunk_recursed_bytes), i )
4163                         && (
4164                             !j ||
4165                             !PAREN_TEST(RExC_study_chunk_recursed +
4166                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4167                         )
4168                     ) {
4169                         Perl_re_printf( aTHX_ " %d",(int)i);
4170                         break;
4171                     }
4172                 }
4173                 if ( j + 1 < recursed_depth ) {
4174                     Perl_re_printf( aTHX_  ",");
4175                 }
4176             }
4177         }
4178         Perl_re_printf( aTHX_ "\n");
4179     }
4180     );
4181     while ( scan && OP(scan) != END && scan < last ){
4182         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4183                                    node length to get a real minimum (because
4184                                    the folded version may be shorter) */
4185         bool unfolded_multi_char = FALSE;
4186         /* Peephole optimizer: */
4187         DEBUG_STUDYDATA("Peep:", data, depth);
4188         DEBUG_PEEP("Peep", scan, depth);
4189
4190
4191         /* The reason we do this here is that we need to deal with things like
4192          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4193          * parsing code, as each (?:..) is handled by a different invocation of
4194          * reg() -- Yves
4195          */
4196         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4197
4198         /* Follow the next-chain of the current node and optimize
4199            away all the NOTHINGs from it.  */
4200         if (OP(scan) != CURLYX) {
4201             const int max = (reg_off_by_arg[OP(scan)]
4202                        ? I32_MAX
4203                        /* I32 may be smaller than U16 on CRAYs! */
4204                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4205             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4206             int noff;
4207             regnode *n = scan;
4208
4209             /* Skip NOTHING and LONGJMP. */
4210             while ((n = regnext(n))
4211                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4212                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4213                    && off + noff < max)
4214                 off += noff;
4215             if (reg_off_by_arg[OP(scan)])
4216                 ARG(scan) = off;
4217             else
4218                 NEXT_OFF(scan) = off;
4219         }
4220
4221         /* The principal pseudo-switch.  Cannot be a switch, since we
4222            look into several different things.  */
4223         if ( OP(scan) == DEFINEP ) {
4224             SSize_t minlen = 0;
4225             SSize_t deltanext = 0;
4226             SSize_t fake_last_close = 0;
4227             I32 f = SCF_IN_DEFINE;
4228
4229             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4230             scan = regnext(scan);
4231             assert( OP(scan) == IFTHEN );
4232             DEBUG_PEEP("expect IFTHEN", scan, depth);
4233
4234             data_fake.last_closep= &fake_last_close;
4235             minlen = *minlenp;
4236             next = regnext(scan);
4237             scan = NEXTOPER(NEXTOPER(scan));
4238             DEBUG_PEEP("scan", scan, depth);
4239             DEBUG_PEEP("next", next, depth);
4240
4241             /* we suppose the run is continuous, last=next...
4242              * NOTE we dont use the return here! */
4243             (void)study_chunk(pRExC_state, &scan, &minlen,
4244                               &deltanext, next, &data_fake, stopparen,
4245                               recursed_depth, NULL, f, depth+1);
4246
4247             scan = next;
4248         } else
4249         if (
4250             OP(scan) == BRANCH  ||
4251             OP(scan) == BRANCHJ ||
4252             OP(scan) == IFTHEN
4253         ) {
4254             next = regnext(scan);
4255             code = OP(scan);
4256
4257             /* The op(next)==code check below is to see if we
4258              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4259              * IFTHEN is special as it might not appear in pairs.
4260              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4261              * we dont handle it cleanly. */
4262             if (OP(next) == code || code == IFTHEN) {
4263                 /* NOTE - There is similar code to this block below for
4264                  * handling TRIE nodes on a re-study.  If you change stuff here
4265                  * check there too. */
4266                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4267                 regnode_ssc accum;
4268                 regnode * const startbranch=scan;
4269
4270                 if (flags & SCF_DO_SUBSTR) {
4271                     /* Cannot merge strings after this. */
4272                     scan_commit(pRExC_state, data, minlenp, is_inf);
4273                 }
4274
4275                 if (flags & SCF_DO_STCLASS)
4276                     ssc_init_zero(pRExC_state, &accum);
4277
4278                 while (OP(scan) == code) {
4279                     SSize_t deltanext, minnext, fake;
4280                     I32 f = 0;
4281                     regnode_ssc this_class;
4282
4283                     DEBUG_PEEP("Branch", scan, depth);
4284
4285                     num++;
4286                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4287                     if (data) {
4288                         data_fake.whilem_c = data->whilem_c;
4289                         data_fake.last_closep = data->last_closep;
4290                     }
4291                     else
4292                         data_fake.last_closep = &fake;
4293
4294                     data_fake.pos_delta = delta;
4295                     next = regnext(scan);
4296
4297                     scan = NEXTOPER(scan); /* everything */
4298                     if (code != BRANCH)    /* everything but BRANCH */
4299                         scan = NEXTOPER(scan);
4300
4301                     if (flags & SCF_DO_STCLASS) {
4302                         ssc_init(pRExC_state, &this_class);
4303                         data_fake.start_class = &this_class;
4304                         f = SCF_DO_STCLASS_AND;
4305                     }
4306                     if (flags & SCF_WHILEM_VISITED_POS)
4307                         f |= SCF_WHILEM_VISITED_POS;
4308
4309                     /* we suppose the run is continuous, last=next...*/
4310                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4311                                       &deltanext, next, &data_fake, stopparen,
4312                                       recursed_depth, NULL, f,depth+1);
4313
4314                     if (min1 > minnext)
4315                         min1 = minnext;
4316                     if (deltanext == SSize_t_MAX) {
4317                         is_inf = is_inf_internal = 1;
4318                         max1 = SSize_t_MAX;
4319                     } else if (max1 < minnext + deltanext)
4320                         max1 = minnext + deltanext;
4321                     scan = next;
4322                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4323                         pars++;
4324                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4325                         if ( stopmin > minnext)
4326                             stopmin = min + min1;
4327                         flags &= ~SCF_DO_SUBSTR;
4328                         if (data)
4329                             data->flags |= SCF_SEEN_ACCEPT;
4330                     }
4331                     if (data) {
4332                         if (data_fake.flags & SF_HAS_EVAL)
4333                             data->flags |= SF_HAS_EVAL;
4334                         data->whilem_c = data_fake.whilem_c;
4335                     }
4336                     if (flags & SCF_DO_STCLASS)
4337                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4338                 }
4339                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4340                     min1 = 0;
4341                 if (flags & SCF_DO_SUBSTR) {
4342                     data->pos_min += min1;
4343                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4344                         data->pos_delta = SSize_t_MAX;
4345                     else
4346                         data->pos_delta += max1 - min1;
4347                     if (max1 != min1 || is_inf)
4348                         data->longest = &(data->longest_float);
4349                 }
4350                 min += min1;
4351                 if (delta == SSize_t_MAX
4352                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4353                     delta = SSize_t_MAX;
4354                 else
4355                     delta += max1 - min1;
4356                 if (flags & SCF_DO_STCLASS_OR) {
4357                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4358                     if (min1) {
4359                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4360                         flags &= ~SCF_DO_STCLASS;
4361                     }
4362                 }
4363                 else if (flags & SCF_DO_STCLASS_AND) {
4364                     if (min1) {
4365                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4366                         flags &= ~SCF_DO_STCLASS;
4367                     }
4368                     else {
4369                         /* Switch to OR mode: cache the old value of
4370                          * data->start_class */
4371                         INIT_AND_WITHP;
4372                         StructCopy(data->start_class, and_withp, regnode_ssc);
4373                         flags &= ~SCF_DO_STCLASS_AND;
4374                         StructCopy(&accum, data->start_class, regnode_ssc);
4375                         flags |= SCF_DO_STCLASS_OR;
4376                     }
4377                 }
4378
4379                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4380                         OP( startbranch ) == BRANCH )
4381                 {
4382                 /* demq.
4383
4384                    Assuming this was/is a branch we are dealing with: 'scan'
4385                    now points at the item that follows the branch sequence,
4386                    whatever it is. We now start at the beginning of the
4387                    sequence and look for subsequences of
4388
4389                    BRANCH->EXACT=>x1
4390                    BRANCH->EXACT=>x2
4391                    tail
4392
4393                    which would be constructed from a pattern like
4394                    /A|LIST|OF|WORDS/
4395
4396                    If we can find such a subsequence we need to turn the first
4397                    element into a trie and then add the subsequent branch exact
4398                    strings to the trie.
4399
4400                    We have two cases
4401
4402                      1. patterns where the whole set of branches can be
4403                         converted.
4404
4405                      2. patterns where only a subset can be converted.
4406
4407                    In case 1 we can replace the whole set with a single regop
4408                    for the trie. In case 2 we need to keep the start and end
4409                    branches so
4410
4411                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4412                      becomes BRANCH TRIE; BRANCH X;
4413
4414                   There is an additional case, that being where there is a
4415                   common prefix, which gets split out into an EXACT like node
4416                   preceding the TRIE node.
4417
4418                   If x(1..n)==tail then we can do a simple trie, if not we make
4419                   a "jump" trie, such that when we match the appropriate word
4420                   we "jump" to the appropriate tail node. Essentially we turn
4421                   a nested if into a case structure of sorts.
4422
4423                 */
4424
4425                     int made=0;
4426                     if (!re_trie_maxbuff) {
4427                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4428                         if (!SvIOK(re_trie_maxbuff))
4429                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4430                     }
4431                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4432                         regnode *cur;
4433                         regnode *first = (regnode *)NULL;
4434                         regnode *last = (regnode *)NULL;
4435                         regnode *tail = scan;
4436                         U8 trietype = 0;
4437                         U32 count=0;
4438
4439                         /* var tail is used because there may be a TAIL
4440                            regop in the way. Ie, the exacts will point to the
4441                            thing following the TAIL, but the last branch will
4442                            point at the TAIL. So we advance tail. If we
4443                            have nested (?:) we may have to move through several
4444                            tails.
4445                          */
4446
4447                         while ( OP( tail ) == TAIL ) {
4448                             /* this is the TAIL generated by (?:) */
4449                             tail = regnext( tail );
4450                         }
4451
4452
4453                         DEBUG_TRIE_COMPILE_r({
4454                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4455                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4456                               depth+1,
4457                               "Looking for TRIE'able sequences. Tail node is ",
4458                               (UV)(tail - RExC_emit_start),
4459                               SvPV_nolen_const( RExC_mysv )
4460                             );
4461                         });
4462
4463                         /*
4464
4465                             Step through the branches
4466                                 cur represents each branch,
4467                                 noper is the first thing to be matched as part
4468                                       of that branch
4469                                 noper_next is the regnext() of that node.
4470
4471                             We normally handle a case like this
4472                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4473                             support building with NOJUMPTRIE, which restricts
4474                             the trie logic to structures like /FOO|BAR/.
4475
4476                             If noper is a trieable nodetype then the branch is
4477                             a possible optimization target. If we are building
4478                             under NOJUMPTRIE then we require that noper_next is
4479                             the same as scan (our current position in the regex
4480                             program).
4481
4482                             Once we have two or more consecutive such branches
4483                             we can create a trie of the EXACT's contents and
4484                             stitch it in place into the program.
4485
4486                             If the sequence represents all of the branches in
4487                             the alternation we replace the entire thing with a
4488                             single TRIE node.
4489
4490                             Otherwise when it is a subsequence we need to
4491                             stitch it in place and replace only the relevant
4492                             branches. This means the first branch has to remain
4493                             as it is used by the alternation logic, and its
4494                             next pointer, and needs to be repointed at the item
4495                             on the branch chain following the last branch we
4496                             have optimized away.
4497
4498                             This could be either a BRANCH, in which case the
4499                             subsequence is internal, or it could be the item
4500                             following the branch sequence in which case the
4501                             subsequence is at the end (which does not
4502                             necessarily mean the first node is the start of the
4503                             alternation).
4504
4505                             TRIE_TYPE(X) is a define which maps the optype to a
4506                             trietype.
4507
4508                                 optype          |  trietype
4509                                 ----------------+-----------
4510                                 NOTHING         | NOTHING
4511                                 EXACT           | EXACT
4512                                 EXACTFU         | EXACTFU
4513                                 EXACTFU_SS      | EXACTFU
4514                                 EXACTFA         | EXACTFA
4515                                 EXACTL          | EXACTL
4516                                 EXACTFLU8       | EXACTFLU8
4517
4518
4519                         */
4520 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4521                        ? NOTHING                                            \
4522                        : ( EXACT == (X) )                                   \
4523                          ? EXACT                                            \
4524                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4525                            ? EXACTFU                                        \
4526                            : ( EXACTFA == (X) )                             \
4527                              ? EXACTFA                                      \
4528                              : ( EXACTL == (X) )                            \
4529                                ? EXACTL                                     \
4530                                : ( EXACTFLU8 == (X) )                        \
4531                                  ? EXACTFLU8                                 \
4532                                  : 0 )
4533
4534                         /* dont use tail as the end marker for this traverse */
4535                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4536                             regnode * const noper = NEXTOPER( cur );
4537                             U8 noper_type = OP( noper );
4538                             U8 noper_trietype = TRIE_TYPE( noper_type );
4539 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4540                             regnode * const noper_next = regnext( noper );
4541                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4542                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4543 #endif
4544
4545                             DEBUG_TRIE_COMPILE_r({
4546                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4547                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4548                                    depth+1,
4549                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4550
4551                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4552                                 Perl_re_printf( aTHX_  " -> %d:%s",
4553                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4554
4555                                 if ( noper_next ) {
4556                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4557                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4558                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4559                                 }
4560                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4561                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4562                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4563                                 );
4564                             });
4565
4566                             /* Is noper a trieable nodetype that can be merged
4567                              * with the current trie (if there is one)? */
4568                             if ( noper_trietype
4569                                   &&
4570                                   (
4571                                         ( noper_trietype == NOTHING )
4572                                         || ( trietype == NOTHING )
4573                                         || ( trietype == noper_trietype )
4574                                   )
4575 #ifdef NOJUMPTRIE
4576                                   && noper_next >= tail
4577 #endif
4578                                   && count < U16_MAX)
4579                             {
4580                                 /* Handle mergable triable node Either we are
4581                                  * the first node in a new trieable sequence,
4582                                  * in which case we do some bookkeeping,
4583                                  * otherwise we update the end pointer. */
4584                                 if ( !first ) {
4585                                     first = cur;
4586                                     if ( noper_trietype == NOTHING ) {
4587 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4588                                         regnode * const noper_next = regnext( noper );
4589                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4590                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4591 #endif
4592
4593                                         if ( noper_next_trietype ) {
4594                                             trietype = noper_next_trietype;
4595                                         } else if (noper_next_type)  {
4596                                             /* a NOTHING regop is 1 regop wide.
4597                                              * We need at least two for a trie
4598                                              * so we can't merge this in */
4599                                             first = NULL;
4600                                         }
4601                                     } else {
4602                                         trietype = noper_trietype;
4603                                     }
4604                                 } else {
4605                                     if ( trietype == NOTHING )
4606                                         trietype = noper_trietype;
4607                                     last = cur;
4608                                 }
4609                                 if (first)
4610                                     count++;
4611                             } /* end handle mergable triable node */
4612                             else {
4613                                 /* handle unmergable node -
4614                                  * noper may either be a triable node which can
4615                                  * not be tried together with the current trie,
4616                                  * or a non triable node */
4617                                 if ( last ) {
4618                                     /* If last is set and trietype is not
4619                                      * NOTHING then we have found at least two
4620                                      * triable branch sequences in a row of a
4621                                      * similar trietype so we can turn them
4622                                      * into a trie. If/when we allow NOTHING to
4623                                      * start a trie sequence this condition
4624                                      * will be required, and it isn't expensive
4625                                      * so we leave it in for now. */
4626                                     if ( trietype && trietype != NOTHING )
4627                                         make_trie( pRExC_state,
4628                                                 startbranch, first, cur, tail,
4629                                                 count, trietype, depth+1 );
4630                                     last = NULL; /* note: we clear/update
4631                                                     first, trietype etc below,
4632                                                     so we dont do it here */
4633                                 }
4634                                 if ( noper_trietype
4635 #ifdef NOJUMPTRIE
4636                                      && noper_next >= tail
4637 #endif
4638                                 ){
4639                                     /* noper is triable, so we can start a new
4640                                      * trie sequence */
4641                                     count = 1;
4642                                     first = cur;
4643                                     trietype = noper_trietype;
4644                                 } else if (first) {
4645                                     /* if we already saw a first but the
4646                                      * current node is not triable then we have
4647                                      * to reset the first information. */
4648                                     count = 0;
4649                                     first = NULL;
4650                                     trietype = 0;
4651                                 }
4652                             } /* end handle unmergable node */
4653                         } /* loop over branches */
4654                         DEBUG_TRIE_COMPILE_r({
4655                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4656                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4657                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4658                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4659                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4660                                PL_reg_name[trietype]
4661                             );
4662
4663                         });
4664                         if ( last && trietype ) {
4665                             if ( trietype != NOTHING ) {
4666                                 /* the last branch of the sequence was part of
4667                                  * a trie, so we have to construct it here
4668                                  * outside of the loop */
4669                                 made= make_trie( pRExC_state, startbranch,
4670                                                  first, scan, tail, count,
4671                                                  trietype, depth+1 );
4672 #ifdef TRIE_STUDY_OPT
4673                                 if ( ((made == MADE_EXACT_TRIE &&
4674                                      startbranch == first)
4675                                      || ( first_non_open == first )) &&
4676                                      depth==0 ) {
4677                                     flags |= SCF_TRIE_RESTUDY;
4678                                     if ( startbranch == first
4679                                          && scan >= tail )
4680                                     {
4681                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4682                                     }
4683                                 }
4684 #endif
4685                             } else {
4686                                 /* at this point we know whatever we have is a
4687                                  * NOTHING sequence/branch AND if 'startbranch'
4688                                  * is 'first' then we can turn the whole thing
4689                                  * into a NOTHING
4690                                  */
4691                                 if ( startbranch == first ) {
4692                                     regnode *opt;
4693                                     /* the entire thing is a NOTHING sequence,
4694                                      * something like this: (?:|) So we can
4695                                      * turn it into a plain NOTHING op. */
4696                                     DEBUG_TRIE_COMPILE_r({
4697                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4698                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4699                                           depth+1,
4700                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4701
4702                                     });
4703                                     OP(startbranch)= NOTHING;
4704                                     NEXT_OFF(startbranch)= tail - startbranch;
4705                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4706                                         OP(opt)= OPTIMIZED;
4707                                 }
4708                             }
4709                         } /* end if ( last) */
4710                     } /* TRIE_MAXBUF is non zero */
4711
4712                 } /* do trie */
4713
4714             }
4715             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4716                 scan = NEXTOPER(NEXTOPER(scan));
4717             } else                      /* single branch is optimized. */
4718                 scan = NEXTOPER(scan);
4719             continue;
4720         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4721             I32 paren = 0;
4722             regnode *start = NULL;
4723             regnode *end = NULL;
4724             U32 my_recursed_depth= recursed_depth;
4725
4726             if (OP(scan) != SUSPEND) { /* GOSUB */
4727                 /* Do setup, note this code has side effects beyond
4728                  * the rest of this block. Specifically setting
4729                  * RExC_recurse[] must happen at least once during
4730                  * study_chunk(). */
4731                 paren = ARG(scan);
4732                 RExC_recurse[ARG2L(scan)] = scan;
4733                 start = RExC_open_parens[paren];
4734                 end   = RExC_close_parens[paren];
4735
4736                 /* NOTE we MUST always execute the above code, even
4737                  * if we do nothing with a GOSUB */
4738                 if (
4739                     ( flags & SCF_IN_DEFINE )
4740                     ||
4741                     (
4742                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4743                         &&
4744                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4745                     )
4746                 ) {
4747                     /* no need to do anything here if we are in a define. */
4748                     /* or we are after some kind of infinite construct
4749                      * so we can skip recursing into this item.
4750                      * Since it is infinite we will not change the maxlen
4751                      * or delta, and if we miss something that might raise
4752                      * the minlen it will merely pessimise a little.
4753                      *
4754                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4755                      * might result in a minlen of 1 and not of 4,
4756                      * but this doesn't make us mismatch, just try a bit
4757                      * harder than we should.
4758                      * */
4759                     scan= regnext(scan);
4760                     continue;
4761                 }
4762
4763                 if (
4764                     !recursed_depth
4765                     ||
4766                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4767                 ) {
4768                     /* it is quite possible that there are more efficient ways
4769                      * to do this. We maintain a bitmap per level of recursion
4770                      * of which patterns we have entered so we can detect if a
4771                      * pattern creates a possible infinite loop. When we
4772                      * recurse down a level we copy the previous levels bitmap
4773                      * down. When we are at recursion level 0 we zero the top
4774                      * level bitmap. It would be nice to implement a different
4775                      * more efficient way of doing this. In particular the top
4776                      * level bitmap may be unnecessary.
4777                      */
4778                     if (!recursed_depth) {
4779                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4780                     } else {
4781                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4782                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4783                              RExC_study_chunk_recursed_bytes, U8);
4784                     }
4785                     /* we havent recursed into this paren yet, so recurse into it */
4786                     DEBUG_STUDYDATA("gosub-set:", data,depth);
4787                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4788                     my_recursed_depth= recursed_depth + 1;
4789                 } else {
4790                     DEBUG_STUDYDATA("gosub-inf:", data,depth);
4791                     /* some form of infinite recursion, assume infinite length
4792                      * */
4793                     if (flags & SCF_DO_SUBSTR) {
4794                         scan_commit(pRExC_state, data, minlenp, is_inf);
4795                         data->longest = &(data->longest_float);
4796                     }
4797                     is_inf = is_inf_internal = 1;
4798                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4799                         ssc_anything(data->start_class);
4800                     flags &= ~SCF_DO_STCLASS;
4801
4802                     start= NULL; /* reset start so we dont recurse later on. */
4803                 }
4804             } else {
4805                 paren = stopparen;
4806                 start = scan + 2;
4807                 end = regnext(scan);
4808             }
4809             if (start) {
4810                 scan_frame *newframe;
4811                 assert(end);
4812                 if (!RExC_frame_last) {
4813                     Newxz(newframe, 1, scan_frame);
4814                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4815                     RExC_frame_head= newframe;
4816                     RExC_frame_count++;
4817                 } else if (!RExC_frame_last->next_frame) {
4818                     Newxz(newframe,1,scan_frame);
4819                     RExC_frame_last->next_frame= newframe;
4820                     newframe->prev_frame= RExC_frame_last;
4821                     RExC_frame_count++;
4822                 } else {
4823                     newframe= RExC_frame_last->next_frame;
4824                 }
4825                 RExC_frame_last= newframe;
4826
4827                 newframe->next_regnode = regnext(scan);
4828                 newframe->last_regnode = last;
4829                 newframe->stopparen = stopparen;
4830                 newframe->prev_recursed_depth = recursed_depth;
4831                 newframe->this_prev_frame= frame;
4832
4833                 DEBUG_STUDYDATA("frame-new:",data,depth);
4834                 DEBUG_PEEP("fnew", scan, depth);
4835
4836                 frame = newframe;
4837                 scan =  start;
4838                 stopparen = paren;
4839                 last = end;
4840                 depth = depth + 1;
4841                 recursed_depth= my_recursed_depth;
4842
4843                 continue;
4844             }
4845         }
4846         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4847             SSize_t l = STR_LEN(scan);
4848             UV uc;
4849             if (UTF) {
4850                 const U8 * const s = (U8*)STRING(scan);
4851                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4852                 l = utf8_length(s, s + l);
4853             } else {
4854                 uc = *((U8*)STRING(scan));
4855             }
4856             min += l;
4857             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4858                 /* The code below prefers earlier match for fixed
4859                    offset, later match for variable offset.  */
4860                 if (data->last_end == -1) { /* Update the start info. */
4861                     data->last_start_min = data->pos_min;
4862                     data->last_start_max = is_inf
4863                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4864                 }
4865                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4866                 if (UTF)
4867                     SvUTF8_on(data->last_found);
4868                 {
4869                     SV * const sv = data->last_found;
4870                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4871                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4872                     if (mg && mg->mg_len >= 0)
4873                         mg->mg_len += utf8_length((U8*)STRING(scan),
4874                                               (U8*)STRING(scan)+STR_LEN(scan));
4875                 }
4876                 data->last_end = data->pos_min + l;
4877                 data->pos_min += l; /* As in the first entry. */
4878                 data->flags &= ~SF_BEFORE_EOL;
4879             }
4880
4881             /* ANDing the code point leaves at most it, and not in locale, and
4882              * can't match null string */
4883             if (flags & SCF_DO_STCLASS_AND) {
4884                 ssc_cp_and(data->start_class, uc);
4885                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4886                 ssc_clear_locale(data->start_class);
4887             }
4888             else if (flags & SCF_DO_STCLASS_OR) {
4889                 ssc_add_cp(data->start_class, uc);
4890                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4891
4892                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4893                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4894             }
4895             flags &= ~SCF_DO_STCLASS;
4896         }
4897         else if (PL_regkind[OP(scan)] == EXACT) {
4898             /* But OP != EXACT!, so is EXACTFish */
4899             SSize_t l = STR_LEN(scan);
4900             const U8 * s = (U8*)STRING(scan);
4901
4902             /* Search for fixed substrings supports EXACT only. */
4903             if (flags & SCF_DO_SUBSTR) {
4904                 assert(data);
4905                 scan_commit(pRExC_state, data, minlenp, is_inf);
4906             }
4907             if (UTF) {
4908                 l = utf8_length(s, s + l);
4909             }
4910             if (unfolded_multi_char) {
4911                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4912             }
4913             min += l - min_subtract;
4914             assert (min >= 0);
4915             delta += min_subtract;
4916             if (flags & SCF_DO_SUBSTR) {
4917                 data->pos_min += l - min_subtract;
4918                 if (data->pos_min < 0) {
4919                     data->pos_min = 0;
4920                 }
4921                 data->pos_delta += min_subtract;
4922                 if (min_subtract) {
4923                     data->longest = &(data->longest_float);
4924                 }
4925             }
4926
4927             if (flags & SCF_DO_STCLASS) {
4928                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4929
4930                 assert(EXACTF_invlist);
4931                 if (flags & SCF_DO_STCLASS_AND) {
4932                     if (OP(scan) != EXACTFL)
4933                         ssc_clear_locale(data->start_class);
4934                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4935                     ANYOF_POSIXL_ZERO(data->start_class);
4936                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4937                 }
4938                 else {  /* SCF_DO_STCLASS_OR */
4939                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4940                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4941
4942                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4943                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4944                 }
4945                 flags &= ~SCF_DO_STCLASS;
4946                 SvREFCNT_dec(EXACTF_invlist);
4947             }
4948         }
4949         else if (REGNODE_VARIES(OP(scan))) {
4950             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4951             I32 fl = 0, f = flags;
4952             regnode * const oscan = scan;
4953             regnode_ssc this_class;
4954             regnode_ssc *oclass = NULL;
4955             I32 next_is_eval = 0;
4956
4957             switch (PL_regkind[OP(scan)]) {
4958             case WHILEM:                /* End of (?:...)* . */
4959                 scan = NEXTOPER(scan);
4960                 goto finish;
4961             case PLUS:
4962                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4963                     next = NEXTOPER(scan);
4964                     if (OP(next) == EXACT
4965                         || OP(next) == EXACTL
4966                         || (flags & SCF_DO_STCLASS))
4967                     {
4968                         mincount = 1;
4969                         maxcount = REG_INFTY;
4970                         next = regnext(scan);
4971                         scan = NEXTOPER(scan);
4972                         goto do_curly;
4973                     }
4974                 }
4975                 if (flags & SCF_DO_SUBSTR)
4976                     data->pos_min++;
4977                 min++;
4978                 /* FALLTHROUGH */
4979             case STAR:
4980                 if (flags & SCF_DO_STCLASS) {
4981                     mincount = 0;
4982                     maxcount = REG_INFTY;
4983                     next = regnext(scan);
4984                     scan = NEXTOPER(scan);
4985                     goto do_curly;
4986                 }
4987                 if (flags & SCF_DO_SUBSTR) {
4988                     scan_commit(pRExC_state, data, minlenp, is_inf);
4989                     /* Cannot extend fixed substrings */
4990                     data->longest = &(data->longest_float);
4991                 }
4992                 is_inf = is_inf_internal = 1;
4993                 scan = regnext(scan);
4994                 goto optimize_curly_tail;
4995             case CURLY:
4996                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4997                     && (scan->flags == stopparen))
4998                 {
4999                     mincount = 1;
5000                     maxcount = 1;
5001                 } else {
5002                     mincount = ARG1(scan);
5003                     maxcount = ARG2(scan);
5004                 }
5005                 next = regnext(scan);
5006                 if (OP(scan) == CURLYX) {
5007                     I32 lp = (data ? *(data->last_closep) : 0);
5008                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5009                 }
5010                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5011                 next_is_eval = (OP(scan) == EVAL);
5012               do_curly:
5013                 if (flags & SCF_DO_SUBSTR) {
5014                     if (mincount == 0)
5015                         scan_commit(pRExC_state, data, minlenp, is_inf);
5016                     /* Cannot extend fixed substrings */
5017                     pos_before = data->pos_min;
5018                 }
5019                 if (data) {
5020                     fl = data->flags;
5021                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5022                     if (is_inf)
5023                         data->flags |= SF_IS_INF;
5024                 }
5025                 if (flags & SCF_DO_STCLASS) {
5026                     ssc_init(pRExC_state, &this_class);
5027                     oclass = data->start_class;
5028                     data->start_class = &this_class;
5029                     f |= SCF_DO_STCLASS_AND;
5030                     f &= ~SCF_DO_STCLASS_OR;
5031                 }
5032                 /* Exclude from super-linear cache processing any {n,m}
5033                    regops for which the combination of input pos and regex
5034                    pos is not enough information to determine if a match
5035                    will be possible.
5036
5037                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5038                    regex pos at the \s*, the prospects for a match depend not
5039                    only on the input position but also on how many (bar\s*)
5040                    repeats into the {4,8} we are. */
5041                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5042                     f &= ~SCF_WHILEM_VISITED_POS;
5043
5044                 /* This will finish on WHILEM, setting scan, or on NULL: */
5045                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5046                                   last, data, stopparen, recursed_depth, NULL,
5047                                   (mincount == 0
5048                                    ? (f & ~SCF_DO_SUBSTR)
5049                                    : f)
5050                                   ,depth+1);
5051
5052                 if (flags & SCF_DO_STCLASS)
5053                     data->start_class = oclass;
5054                 if (mincount == 0 || minnext == 0) {
5055                     if (flags & SCF_DO_STCLASS_OR) {
5056                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5057                     }
5058                     else if (flags & SCF_DO_STCLASS_AND) {
5059                         /* Switch to OR mode: cache the old value of
5060                          * data->start_class */
5061                         INIT_AND_WITHP;
5062                         StructCopy(data->start_class, and_withp, regnode_ssc);
5063                         flags &= ~SCF_DO_STCLASS_AND;
5064                         StructCopy(&this_class, data->start_class, regnode_ssc);
5065                         flags |= SCF_DO_STCLASS_OR;
5066                         ANYOF_FLAGS(data->start_class)
5067                                                 |= SSC_MATCHES_EMPTY_STRING;
5068                     }
5069                 } else {                /* Non-zero len */
5070                     if (flags & SCF_DO_STCLASS_OR) {
5071                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5072                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5073                     }
5074                     else if (flags & SCF_DO_STCLASS_AND)
5075                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5076                     flags &= ~SCF_DO_STCLASS;
5077                 }
5078                 if (!scan)              /* It was not CURLYX, but CURLY. */
5079                     scan = next;
5080                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
5081                     /* ? quantifier ok, except for (?{ ... }) */
5082                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5083                     && (minnext == 0) && (deltanext == 0)
5084                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5085                     && maxcount <= REG_INFTY/3) /* Complement check for big
5086                                                    count */
5087                 {
5088                     /* Fatal warnings may leak the regexp without this: */
5089                     SAVEFREESV(RExC_rx_sv);
5090                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5091                         "Quantifier unexpected on zero-length expression "
5092                         "in regex m/%" UTF8f "/",
5093                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5094                                   RExC_precomp));
5095                     (void)ReREFCNT_inc(RExC_rx_sv);
5096                 }
5097
5098                 min += minnext * mincount;
5099                 is_inf_internal |= deltanext == SSize_t_MAX
5100                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5101                 is_inf |= is_inf_internal;
5102                 if (is_inf) {
5103                     delta = SSize_t_MAX;
5104                 } else {
5105                     delta += (minnext + deltanext) * maxcount
5106                              - minnext * mincount;
5107                 }
5108                 /* Try powerful optimization CURLYX => CURLYN. */
5109                 if (  OP(oscan) == CURLYX && data
5110                       && data->flags & SF_IN_PAR
5111                       && !(data->flags & SF_HAS_EVAL)
5112                       && !deltanext && minnext == 1 ) {
5113                     /* Try to optimize to CURLYN.  */
5114                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5115                     regnode * const nxt1 = nxt;
5116 #ifdef DEBUGGING
5117                     regnode *nxt2;
5118 #endif
5119
5120                     /* Skip open. */
5121                     nxt = regnext(nxt);
5122                     if (!REGNODE_SIMPLE(OP(nxt))
5123                         && !(PL_regkind[OP(nxt)] == EXACT
5124                              && STR_LEN(nxt) == 1))
5125                         goto nogo;
5126 #ifdef DEBUGGING
5127                     nxt2 = nxt;
5128 #endif
5129                     nxt = regnext(nxt);
5130                     if (OP(nxt) != CLOSE)
5131                         goto nogo;
5132                     if (RExC_open_parens) {
5133                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5134                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5135                     }
5136                     /* Now we know that nxt2 is the only contents: */
5137                     oscan->flags = (U8)ARG(nxt);
5138                     OP(oscan) = CURLYN;
5139                     OP(nxt1) = NOTHING; /* was OPEN. */
5140
5141 #ifdef DEBUGGING
5142                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5143                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5144                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5145                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5146                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5147                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5148 #endif
5149                 }
5150               nogo:
5151
5152                 /* Try optimization CURLYX => CURLYM. */
5153                 if (  OP(oscan) == CURLYX && data
5154                       && !(data->flags & SF_HAS_PAR)
5155                       && !(data->flags & SF_HAS_EVAL)
5156                       && !deltanext     /* atom is fixed width */
5157                       && minnext != 0   /* CURLYM can't handle zero width */
5158
5159                          /* Nor characters whose fold at run-time may be
5160                           * multi-character */
5161                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5162                 ) {
5163                     /* XXXX How to optimize if data == 0? */
5164                     /* Optimize to a simpler form.  */
5165                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5166                     regnode *nxt2;
5167
5168                     OP(oscan) = CURLYM;
5169                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5170                             && (OP(nxt2) != WHILEM))
5171                         nxt = nxt2;
5172                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5173                     /* Need to optimize away parenths. */
5174                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5175                         /* Set the parenth number.  */
5176                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5177
5178                         oscan->flags = (U8)ARG(nxt);
5179                         if (RExC_open_parens) {
5180                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5181                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5182                         }
5183                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5184                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5185
5186 #ifdef DEBUGGING
5187                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5188                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5189                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5190                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5191 #endif
5192 #if 0
5193                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5194                             regnode *nnxt = regnext(nxt1);
5195                             if (nnxt == nxt) {
5196                                 if (reg_off_by_arg[OP(nxt1)])
5197                                     ARG_SET(nxt1, nxt2 - nxt1);
5198                                 else if (nxt2 - nxt1 < U16_MAX)
5199                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5200                                 else
5201                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5202                             }
5203                             nxt1 = nnxt;
5204                         }
5205 #endif
5206                         /* Optimize again: */
5207                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5208                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5209                     }
5210                     else
5211                         oscan->flags = 0;
5212                 }
5213                 else if ((OP(oscan) == CURLYX)
5214                          && (flags & SCF_WHILEM_VISITED_POS)
5215                          /* See the comment on a similar expression above.
5216                             However, this time it's not a subexpression
5217                             we care about, but the expression itself. */
5218                          && (maxcount == REG_INFTY)
5219                          && data && ++data->whilem_c < 16) {
5220                     /* This stays as CURLYX, we can put the count/of pair. */
5221                     /* Find WHILEM (as in regexec.c) */
5222                     regnode *nxt = oscan + NEXT_OFF(oscan);
5223
5224                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5225                         nxt += ARG(nxt);
5226                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
5227                         | (RExC_whilem_seen << 4)); /* On WHILEM */
5228                 }
5229                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5230                     pars++;
5231                 if (flags & SCF_DO_SUBSTR) {
5232                     SV *last_str = NULL;
5233                     STRLEN last_chrs = 0;
5234                     int counted = mincount != 0;
5235
5236                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5237                                                                   string. */
5238                         SSize_t b = pos_before >= data->last_start_min
5239                             ? pos_before : data->last_start_min;
5240                         STRLEN l;
5241                         const char * const s = SvPV_const(data->last_found, l);
5242                         SSize_t old = b - data->last_start_min;
5243
5244                         if (UTF)
5245                             old = utf8_hop((U8*)s, old) - (U8*)s;
5246                         l -= old;
5247                         /* Get the added string: */
5248                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5249                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5250                                             (U8*)(s + old + l)) : l;
5251                         if (deltanext == 0 && pos_before == b) {
5252                             /* What was added is a constant string */
5253                             if (mincount > 1) {
5254
5255                                 SvGROW(last_str, (mincount * l) + 1);
5256                                 repeatcpy(SvPVX(last_str) + l,
5257                                           SvPVX_const(last_str), l,
5258                                           mincount - 1);
5259                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5260                                 /* Add additional parts. */
5261                                 SvCUR_set(data->last_found,
5262                                           SvCUR(data->last_found) - l);
5263                                 sv_catsv(data->last_found, last_str);
5264                                 {
5265                                     SV * sv = data->last_found;
5266                                     MAGIC *mg =
5267                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5268                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5269                                     if (mg && mg->mg_len >= 0)
5270                                         mg->mg_len += last_chrs * (mincount-1);
5271                                 }
5272                                 last_chrs *= mincount;
5273                                 data->last_end += l * (mincount - 1);
5274                             }
5275                         } else {
5276                             /* start offset must point into the last copy */
5277                             data->last_start_min += minnext * (mincount - 1);
5278                             data->last_start_max =
5279                               is_inf
5280                                ? SSize_t_MAX
5281                                : data->last_start_max +
5282                                  (maxcount - 1) * (minnext + data->pos_delta);
5283                         }
5284                     }
5285                     /* It is counted once already... */
5286                     data->pos_min += minnext * (mincount - counted);
5287 #if 0
5288 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5289                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5290                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5291     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5292     (UV)mincount);
5293 if (deltanext != SSize_t_MAX)
5294 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5295     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5296           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5297 #endif
5298                     if (deltanext == SSize_t_MAX
5299                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5300                         data->pos_delta = SSize_t_MAX;
5301                     else
5302                         data->pos_delta += - counted * deltanext +
5303                         (minnext + deltanext) * maxcount - minnext * mincount;
5304                     if (mincount != maxcount) {
5305                          /* Cannot extend fixed substrings found inside
5306                             the group.  */
5307                         scan_commit(pRExC_state, data, minlenp, is_inf);
5308                         if (mincount && last_str) {
5309                             SV * const sv = data->last_found;
5310                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5311                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5312
5313                             if (mg)
5314                                 mg->mg_len = -1;
5315                             sv_setsv(sv, last_str);
5316                             data->last_end = data->pos_min;
5317                             data->last_start_min = data->pos_min - last_chrs;
5318                             data->last_start_max = is_inf
5319                                 ? SSize_t_MAX
5320                                 : data->pos_min + data->pos_delta - last_chrs;
5321                         }
5322                         data->longest = &(data->longest_float);
5323                     }
5324                     SvREFCNT_dec(last_str);
5325                 }
5326                 if (data && (fl & SF_HAS_EVAL))
5327                     data->flags |= SF_HAS_EVAL;
5328               optimize_curly_tail:
5329                 if (OP(oscan) != CURLYX) {
5330                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5331                            && NEXT_OFF(next))
5332                         NEXT_OFF(oscan) += NEXT_OFF(next);
5333                 }
5334                 continue;
5335
5336             default:
5337 #ifdef DEBUGGING
5338                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5339                                                                     OP(scan));
5340 #endif
5341             case REF:
5342             case CLUMP:
5343                 if (flags & SCF_DO_SUBSTR) {
5344                     /* Cannot expect anything... */
5345                     scan_commit(pRExC_state, data, minlenp, is_inf);
5346                     data->longest = &(data->longest_float);
5347                 }
5348                 is_inf = is_inf_internal = 1;
5349                 if (flags & SCF_DO_STCLASS_OR) {
5350                     if (OP(scan) == CLUMP) {
5351                         /* Actually is any start char, but very few code points
5352                          * aren't start characters */
5353                         ssc_match_all_cp(data->start_class);
5354                     }
5355                     else {
5356                         ssc_anything(data->start_class);
5357                     }
5358                 }
5359                 flags &= ~SCF_DO_STCLASS;
5360                 break;
5361             }
5362         }
5363         else if (OP(scan) == LNBREAK) {
5364             if (flags & SCF_DO_STCLASS) {
5365                 if (flags & SCF_DO_STCLASS_AND) {
5366                     ssc_intersection(data->start_class,
5367                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5368                     ssc_clear_locale(data->start_class);
5369                     ANYOF_FLAGS(data->start_class)
5370                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5371                 }
5372                 else if (flags & SCF_DO_STCLASS_OR) {
5373                     ssc_union(data->start_class,
5374                               PL_XPosix_ptrs[_CC_VERTSPACE],
5375                               FALSE);
5376                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5377
5378                     /* See commit msg for
5379                      * 749e076fceedeb708a624933726e7989f2302f6a */
5380                     ANYOF_FLAGS(data->start_class)
5381                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5382                 }
5383                 flags &= ~SCF_DO_STCLASS;
5384             }
5385             min++;
5386             if (delta != SSize_t_MAX)
5387                 delta++;    /* Because of the 2 char string cr-lf */
5388             if (flags & SCF_DO_SUBSTR) {
5389                 /* Cannot expect anything... */
5390                 scan_commit(pRExC_state, data, minlenp, is_inf);
5391                 data->pos_min += 1;
5392                 data->pos_delta += 1;
5393                 data->longest = &(data->longest_float);
5394             }
5395         }
5396         else if (REGNODE_SIMPLE(OP(scan))) {
5397
5398             if (flags & SCF_DO_SUBSTR) {
5399                 scan_commit(pRExC_state, data, minlenp, is_inf);
5400                 data->pos_min++;
5401             }
5402             min++;
5403             if (flags & SCF_DO_STCLASS) {
5404                 bool invert = 0;
5405                 SV* my_invlist = NULL;
5406                 U8 namedclass;
5407
5408                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5409                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5410
5411                 /* Some of the logic below assumes that switching
5412                    locale on will only add false positives. */
5413                 switch (OP(scan)) {
5414
5415                 default:
5416 #ifdef DEBUGGING
5417                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5418                                                                      OP(scan));
5419 #endif
5420                 case SANY:
5421                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5422                         ssc_match_all_cp(data->start_class);
5423                     break;
5424
5425                 case REG_ANY:
5426                     {
5427                         SV* REG_ANY_invlist = _new_invlist(2);
5428                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5429                                                             '\n');
5430                         if (flags & SCF_DO_STCLASS_OR) {
5431                             ssc_union(data->start_class,
5432                                       REG_ANY_invlist,
5433                                       TRUE /* TRUE => invert, hence all but \n
5434                                             */
5435                                       );
5436                         }
5437                         else if (flags & SCF_DO_STCLASS_AND) {
5438                             ssc_intersection(data->start_class,
5439                                              REG_ANY_invlist,
5440                                              TRUE  /* TRUE => invert */
5441                                              );
5442                             ssc_clear_locale(data->start_class);
5443                         }
5444                         SvREFCNT_dec_NN(REG_ANY_invlist);
5445                     }
5446                     break;
5447
5448                 case ANYOFD:
5449                 case ANYOFL:
5450                 case ANYOF:
5451                     if (flags & SCF_DO_STCLASS_AND)
5452                         ssc_and(pRExC_state, data->start_class,
5453                                 (regnode_charclass *) scan);
5454                     else
5455                         ssc_or(pRExC_state, data->start_class,
5456                                                           (regnode_charclass *) scan);
5457                     break;
5458
5459                 case NPOSIXL:
5460                     invert = 1;
5461                     /* FALLTHROUGH */
5462
5463                 case POSIXL:
5464                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5465                     if (flags & SCF_DO_STCLASS_AND) {
5466                         bool was_there = cBOOL(
5467                                           ANYOF_POSIXL_TEST(data->start_class,
5468                                                                  namedclass));
5469                         ANYOF_POSIXL_ZERO(data->start_class);
5470                         if (was_there) {    /* Do an AND */
5471                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5472                         }
5473                         /* No individual code points can now match */
5474                         data->start_class->invlist
5475                                                 = sv_2mortal(_new_invlist(0));
5476                     }
5477                     else {
5478                         int complement = namedclass + ((invert) ? -1 : 1);
5479
5480                         assert(flags & SCF_DO_STCLASS_OR);
5481
5482                         /* If the complement of this class was already there,
5483                          * the result is that they match all code points,
5484                          * (\d + \D == everything).  Remove the classes from
5485                          * future consideration.  Locale is not relevant in
5486                          * this case */
5487                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5488                             ssc_match_all_cp(data->start_class);
5489                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5490                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5491                         }
5492                         else {  /* The usual case; just add this class to the
5493                                    existing set */
5494                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5495                         }
5496                     }
5497                     break;
5498
5499                 case NPOSIXA:   /* For these, we always know the exact set of
5500                                    what's matched */
5501                     invert = 1;
5502                     /* FALLTHROUGH */
5503                 case POSIXA:
5504                     if (FLAGS(scan) == _CC_ASCII) {
5505                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5506                     }
5507                     else {
5508                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5509                                               PL_XPosix_ptrs[_CC_ASCII],
5510                                               &my_invlist);
5511                     }
5512                     goto join_posix;
5513
5514                 case NPOSIXD:
5515                 case NPOSIXU:
5516                     invert = 1;
5517                     /* FALLTHROUGH */
5518                 case POSIXD:
5519                 case POSIXU:
5520                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5521
5522                     /* NPOSIXD matches all upper Latin1 code points unless the
5523                      * target string being matched is UTF-8, which is
5524                      * unknowable until match time.  Since we are going to
5525                      * invert, we want to get rid of all of them so that the
5526                      * inversion will match all */
5527                     if (OP(scan) == NPOSIXD) {
5528                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5529                                           &my_invlist);
5530                     }
5531
5532                   join_posix:
5533
5534                     if (flags & SCF_DO_STCLASS_AND) {
5535                         ssc_intersection(data->start_class, my_invlist, invert);
5536                         ssc_clear_locale(data->start_class);
5537                     }
5538                     else {
5539                         assert(flags & SCF_DO_STCLASS_OR);
5540                         ssc_union(data->start_class, my_invlist, invert);
5541                     }
5542                     SvREFCNT_dec(my_invlist);
5543                 }
5544                 if (flags & SCF_DO_STCLASS_OR)
5545                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5546                 flags &= ~SCF_DO_STCLASS;
5547             }
5548         }
5549         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5550             data->flags |= (OP(scan) == MEOL
5551                             ? SF_BEFORE_MEOL
5552                             : SF_BEFORE_SEOL);
5553             scan_commit(pRExC_state, data, minlenp, is_inf);
5554
5555         }
5556         else if (  PL_regkind[OP(scan)] == BRANCHJ
5557                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5558                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5559                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5560         {
5561             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5562                 || OP(scan) == UNLESSM )
5563             {
5564                 /* Negative Lookahead/lookbehind
5565                    In this case we can't do fixed string optimisation.
5566                 */
5567
5568                 SSize_t deltanext, minnext, fake = 0;
5569                 regnode *nscan;
5570                 regnode_ssc intrnl;
5571                 int f = 0;
5572
5573                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5574                 if (data) {
5575                     data_fake.whilem_c = data->whilem_c;
5576                     data_fake.last_closep = data->last_closep;
5577                 }
5578                 else
5579                     data_fake.last_closep = &fake;
5580                 data_fake.pos_delta = delta;
5581                 if ( flags & SCF_DO_STCLASS && !scan->flags
5582                      && OP(scan) == IFMATCH ) { /* Lookahead */
5583                     ssc_init(pRExC_state, &intrnl);
5584                     data_fake.start_class = &intrnl;
5585                     f |= SCF_DO_STCLASS_AND;
5586                 }
5587                 if (flags & SCF_WHILEM_VISITED_POS)
5588                     f |= SCF_WHILEM_VISITED_POS;
5589                 next = regnext(scan);
5590                 nscan = NEXTOPER(NEXTOPER(scan));
5591                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5592                                       last, &data_fake, stopparen,
5593                                       recursed_depth, NULL, f, depth+1);
5594                 if (scan->flags) {
5595                     if (deltanext) {
5596                         FAIL("Variable length lookbehind not implemented");
5597                     }
5598                     else if (minnext > (I32)U8_MAX) {
5599                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5600                               (UV)U8_MAX);
5601                     }
5602                     scan->flags = (U8)minnext;
5603                 }
5604                 if (data) {
5605                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5606                         pars++;
5607                     if (data_fake.flags & SF_HAS_EVAL)
5608                         data->flags |= SF_HAS_EVAL;
5609                     data->whilem_c = data_fake.whilem_c;
5610                 }
5611                 if (f & SCF_DO_STCLASS_AND) {
5612                     if (flags & SCF_DO_STCLASS_OR) {
5613                         /* OR before, AND after: ideally we would recurse with
5614                          * data_fake to get the AND applied by study of the
5615                          * remainder of the pattern, and then derecurse;
5616                          * *** HACK *** for now just treat as "no information".
5617                          * See [perl #56690].
5618                          */
5619                         ssc_init(pRExC_state, data->start_class);
5620                     }  else {
5621                         /* AND before and after: combine and continue.  These
5622                          * assertions are zero-length, so can match an EMPTY
5623                          * string */
5624                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5625                         ANYOF_FLAGS(data->start_class)
5626                                                    |= SSC_MATCHES_EMPTY_STRING;
5627                     }
5628                 }
5629             }
5630 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5631             else {
5632                 /* Positive Lookahead/lookbehind
5633                    In this case we can do fixed string optimisation,
5634                    but we must be careful about it. Note in the case of
5635                    lookbehind the positions will be offset by the minimum
5636                    length of the pattern, something we won't know about
5637                    until after the recurse.
5638                 */
5639                 SSize_t deltanext, fake = 0;
5640                 regnode *nscan;
5641                 regnode_ssc intrnl;
5642                 int f = 0;
5643                 /* We use SAVEFREEPV so that when the full compile
5644                     is finished perl will clean up the allocated
5645                     minlens when it's all done. This way we don't
5646                     have to worry about freeing them when we know
5647                     they wont be used, which would be a pain.
5648                  */
5649                 SSize_t *minnextp;
5650                 Newx( minnextp, 1, SSize_t );
5651                 SAVEFREEPV(minnextp);
5652
5653                 if (data) {
5654                     StructCopy(data, &data_fake, scan_data_t);
5655                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5656                         f |= SCF_DO_SUBSTR;
5657                         if (scan->flags)
5658                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5659                         data_fake.last_found=newSVsv(data->last_found);
5660                     }
5661                 }
5662                 else
5663                     data_fake.last_closep = &fake;
5664                 data_fake.flags = 0;
5665                 data_fake.pos_delta = delta;
5666                 if (is_inf)
5667                     data_fake.flags |= SF_IS_INF;
5668                 if ( flags & SCF_DO_STCLASS && !scan->flags
5669                      && OP(scan) == IFMATCH ) { /* Lookahead */
5670                     ssc_init(pRExC_state, &intrnl);
5671                     data_fake.start_class = &intrnl;
5672                     f |= SCF_DO_STCLASS_AND;
5673                 }
5674                 if (flags & SCF_WHILEM_VISITED_POS)
5675                     f |= SCF_WHILEM_VISITED_POS;
5676                 next = regnext(scan);
5677                 nscan = NEXTOPER(NEXTOPER(scan));
5678
5679                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5680                                         &deltanext, last, &data_fake,
5681                                         stopparen, recursed_depth, NULL,
5682                                         f,depth+1);
5683                 if (scan->flags) {
5684                     if (deltanext) {
5685                         FAIL("Variable length lookbehind not implemented");
5686                     }
5687                     else if (*minnextp > (I32)U8_MAX) {
5688                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5689                               (UV)U8_MAX);
5690                     }
5691                     scan->flags = (U8)*minnextp;
5692                 }
5693
5694                 *minnextp += min;
5695
5696                 if (f & SCF_DO_STCLASS_AND) {
5697                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5698                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5699                 }
5700                 if (data) {
5701                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5702                         pars++;
5703                     if (data_fake.flags & SF_HAS_EVAL)
5704                         data->flags |= SF_HAS_EVAL;
5705                     data->whilem_c = data_fake.whilem_c;
5706                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5707                         if (RExC_rx->minlen<*minnextp)
5708                             RExC_rx->minlen=*minnextp;
5709                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5710                         SvREFCNT_dec_NN(data_fake.last_found);
5711
5712                         if ( data_fake.minlen_fixed != minlenp )
5713                         {
5714                             data->offset_fixed= data_fake.offset_fixed;
5715                             data->minlen_fixed= data_fake.minlen_fixed;
5716                             data->lookbehind_fixed+= scan->flags;
5717                         }
5718                         if ( data_fake.minlen_float != minlenp )
5719                         {
5720                             data->minlen_float= data_fake.minlen_float;
5721                             data->offset_float_min=data_fake.offset_float_min;
5722                             data->offset_float_max=data_fake.offset_float_max;
5723                             data->lookbehind_float+= scan->flags;
5724                         }
5725                     }
5726                 }
5727             }
5728 #endif
5729         }
5730         else if (OP(scan) == OPEN) {
5731             if (stopparen != (I32)ARG(scan))
5732                 pars++;
5733         }
5734         else if (OP(scan) == CLOSE) {
5735             if (stopparen == (I32)ARG(scan)) {
5736                 break;
5737             }
5738             if ((I32)ARG(scan) == is_par) {
5739                 next = regnext(scan);
5740
5741                 if ( next && (OP(next) != WHILEM) && next < last)
5742                     is_par = 0;         /* Disable optimization */
5743             }
5744             if (data)
5745                 *(data->last_closep) = ARG(scan);
5746         }
5747         else if (OP(scan) == EVAL) {
5748                 if (data)
5749                     data->flags |= SF_HAS_EVAL;
5750         }
5751         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5752             if (flags & SCF_DO_SUBSTR) {
5753                 scan_commit(pRExC_state, data, minlenp, is_inf);
5754                 flags &= ~SCF_DO_SUBSTR;
5755             }
5756             if (data && OP(scan)==ACCEPT) {
5757                 data->flags |= SCF_SEEN_ACCEPT;
5758                 if (stopmin > min)
5759                     stopmin = min;
5760             }
5761         }
5762         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5763         {
5764                 if (flags & SCF_DO_SUBSTR) {
5765                     scan_commit(pRExC_state, data, minlenp, is_inf);
5766                     data->longest = &(data->longest_float);
5767                 }
5768                 is_inf = is_inf_internal = 1;
5769                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5770                     ssc_anything(data->start_class);
5771                 flags &= ~SCF_DO_STCLASS;
5772         }
5773         else if (OP(scan) == GPOS) {
5774             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5775                 !(delta || is_inf || (data && data->pos_delta)))
5776             {
5777                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5778                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5779                 if (RExC_rx->gofs < (STRLEN)min)
5780                     RExC_rx->gofs = min;
5781             } else {
5782                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5783                 RExC_rx->gofs = 0;
5784             }
5785         }
5786 #ifdef TRIE_STUDY_OPT
5787 #ifdef FULL_TRIE_STUDY
5788         else if (PL_regkind[OP(scan)] == TRIE) {
5789             /* NOTE - There is similar code to this block above for handling
5790                BRANCH nodes on the initial study.  If you change stuff here
5791                check there too. */
5792             regnode *trie_node= scan;
5793             regnode *tail= regnext(scan);
5794             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5795             SSize_t max1 = 0, min1 = SSize_t_MAX;
5796             regnode_ssc accum;
5797
5798             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5799                 /* Cannot merge strings after this. */
5800                 scan_commit(pRExC_state, data, minlenp, is_inf);
5801             }
5802             if (flags & SCF_DO_STCLASS)
5803                 ssc_init_zero(pRExC_state, &accum);
5804
5805             if (!trie->jump) {
5806                 min1= trie->minlen;
5807                 max1= trie->maxlen;
5808             } else {
5809                 const regnode *nextbranch= NULL;
5810                 U32 word;
5811
5812                 for ( word=1 ; word <= trie->wordcount ; word++)
5813                 {
5814                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5815                     regnode_ssc this_class;
5816
5817                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5818                     if (data) {
5819                         data_fake.whilem_c = data->whilem_c;
5820                         data_fake.last_closep = data->last_closep;
5821                     }
5822                     else
5823                         data_fake.last_closep = &fake;
5824                     data_fake.pos_delta = delta;
5825                     if (flags & SCF_DO_STCLASS) {
5826                         ssc_init(pRExC_state, &this_class);
5827                         data_fake.start_class = &this_class;
5828                         f = SCF_DO_STCLASS_AND;
5829                     }
5830                     if (flags & SCF_WHILEM_VISITED_POS)
5831                         f |= SCF_WHILEM_VISITED_POS;
5832
5833                     if (trie->jump[word]) {
5834                         if (!nextbranch)
5835                             nextbranch = trie_node + trie->jump[0];
5836                         scan= trie_node + trie->jump[word];
5837                         /* We go from the jump point to the branch that follows
5838                            it. Note this means we need the vestigal unused
5839                            branches even though they arent otherwise used. */
5840                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5841                             &deltanext, (regnode *)nextbranch, &data_fake,
5842                             stopparen, recursed_depth, NULL, f,depth+1);
5843                     }
5844                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5845                         nextbranch= regnext((regnode*)nextbranch);
5846
5847                     if (min1 > (SSize_t)(minnext + trie->minlen))
5848                         min1 = minnext + trie->minlen;
5849                     if (deltanext == SSize_t_MAX) {
5850                         is_inf = is_inf_internal = 1;
5851                         max1 = SSize_t_MAX;
5852                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5853                         max1 = minnext + deltanext + trie->maxlen;
5854
5855                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5856                         pars++;
5857                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5858                         if ( stopmin > min + min1)
5859                             stopmin = min + min1;
5860                         flags &= ~SCF_DO_SUBSTR;
5861                         if (data)
5862                             data->flags |= SCF_SEEN_ACCEPT;
5863                     }
5864                     if (data) {
5865                         if (data_fake.flags & SF_HAS_EVAL)
5866                             data->flags |= SF_HAS_EVAL;
5867                         data->whilem_c = data_fake.whilem_c;
5868                     }
5869                     if (flags & SCF_DO_STCLASS)
5870                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5871                 }
5872             }
5873             if (flags & SCF_DO_SUBSTR) {
5874                 data->pos_min += min1;
5875                 data->pos_delta += max1 - min1;
5876                 if (max1 != min1 || is_inf)
5877                     data->longest = &(data->longest_float);
5878             }
5879             min += min1;
5880             if (delta != SSize_t_MAX)
5881                 delta += max1 - min1;
5882             if (flags & SCF_DO_STCLASS_OR) {
5883                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5884                 if (min1) {
5885                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5886                     flags &= ~SCF_DO_STCLASS;
5887                 }
5888             }
5889             else if (flags & SCF_DO_STCLASS_AND) {
5890                 if (min1) {
5891                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5892                     flags &= ~SCF_DO_STCLASS;
5893                 }
5894                 else {
5895                     /* Switch to OR mode: cache the old value of
5896                      * data->start_class */
5897                     INIT_AND_WITHP;
5898                     StructCopy(data->start_class, and_withp, regnode_ssc);
5899                     flags &= ~SCF_DO_STCLASS_AND;
5900                     StructCopy(&accum, data->start_class, regnode_ssc);
5901                     flags |= SCF_DO_STCLASS_OR;
5902                 }
5903             }
5904             scan= tail;
5905             continue;
5906         }
5907 #else
5908         else if (PL_regkind[OP(scan)] == TRIE) {
5909             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5910             U8*bang=NULL;
5911
5912             min += trie->minlen;
5913             delta += (trie->maxlen - trie->minlen);
5914             flags &= ~SCF_DO_STCLASS; /* xxx */
5915             if (flags & SCF_DO_SUBSTR) {
5916                 /* Cannot expect anything... */
5917                 scan_commit(pRExC_state, data, minlenp, is_inf);
5918                 data->pos_min += trie->minlen;
5919                 data->pos_delta += (trie->maxlen - trie->minlen);
5920                 if (trie->maxlen != trie->minlen)
5921                     data->longest = &(data->longest_float);
5922             }
5923             if (trie->jump) /* no more substrings -- for now /grr*/
5924                flags &= ~SCF_DO_SUBSTR;
5925         }
5926 #endif /* old or new */
5927 #endif /* TRIE_STUDY_OPT */
5928
5929         /* Else: zero-length, ignore. */
5930         scan = regnext(scan);
5931     }
5932
5933   finish:
5934     if (frame) {
5935         /* we need to unwind recursion. */
5936         depth = depth - 1;
5937
5938         DEBUG_STUDYDATA("frame-end:",data,depth);
5939         DEBUG_PEEP("fend", scan, depth);
5940
5941         /* restore previous context */
5942         last = frame->last_regnode;
5943         scan = frame->next_regnode;
5944         stopparen = frame->stopparen;
5945         recursed_depth = frame->prev_recursed_depth;
5946
5947         RExC_frame_last = frame->prev_frame;
5948         frame = frame->this_prev_frame;
5949         goto fake_study_recurse;
5950     }
5951
5952     assert(!frame);
5953     DEBUG_STUDYDATA("pre-fin:",data,depth);
5954
5955     *scanp = scan;
5956     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5957
5958     if (flags & SCF_DO_SUBSTR && is_inf)
5959         data->pos_delta = SSize_t_MAX - data->pos_min;
5960     if (is_par > (I32)U8_MAX)
5961         is_par = 0;
5962     if (is_par && pars==1 && data) {
5963         data->flags |= SF_IN_PAR;
5964         data->flags &= ~SF_HAS_PAR;
5965     }
5966     else if (pars && data) {
5967         data->flags |= SF_HAS_PAR;
5968         data->flags &= ~SF_IN_PAR;
5969     }
5970     if (flags & SCF_DO_STCLASS_OR)
5971         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5972     if (flags & SCF_TRIE_RESTUDY)
5973         data->flags |=  SCF_TRIE_RESTUDY;
5974
5975     DEBUG_STUDYDATA("post-fin:",data,depth);
5976
5977     {
5978         SSize_t final_minlen= min < stopmin ? min : stopmin;
5979
5980         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
5981             if (final_minlen > SSize_t_MAX - delta)
5982                 RExC_maxlen = SSize_t_MAX;
5983             else if (RExC_maxlen < final_minlen + delta)
5984                 RExC_maxlen = final_minlen + delta;
5985         }
5986         return final_minlen;
5987     }
5988     NOT_REACHED; /* NOTREACHED */
5989 }
5990
5991 STATIC U32
5992 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5993 {
5994     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5995
5996     PERL_ARGS_ASSERT_ADD_DATA;
5997
5998     Renewc(RExC_rxi->data,
5999            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6000            char, struct reg_data);
6001     if(count)
6002         Renew(RExC_rxi->data->what, count + n, U8);
6003     else
6004         Newx(RExC_rxi->data->what, n, U8);
6005     RExC_rxi->data->count = count + n;
6006     Copy(s, RExC_rxi->data->what + count, n, U8);
6007     return count;
6008 }
6009
6010 /*XXX: todo make this not included in a non debugging perl, but appears to be
6011  * used anyway there, in 'use re' */
6012 #ifndef PERL_IN_XSUB_RE
6013 void
6014 Perl_reginitcolors(pTHX)
6015 {
6016     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6017     if (s) {
6018         char *t = savepv(s);
6019         int i = 0;
6020         PL_colors[0] = t;
6021         while (++i < 6) {
6022             t = strchr(t, '\t');
6023             if (t) {
6024                 *t = '\0';
6025                 PL_colors[i] = ++t;
6026             }
6027             else
6028                 PL_colors[i] = t = (char *)"";
6029         }
6030     } else {
6031         int i = 0;
6032         while (i < 6)
6033             PL_colors[i++] = (char *)"";
6034     }
6035     PL_colorset = 1;
6036 }
6037 #endif
6038
6039
6040 #ifdef TRIE_STUDY_OPT
6041 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6042     STMT_START {                                            \
6043         if (                                                \
6044               (data.flags & SCF_TRIE_RESTUDY)               \
6045               && ! restudied++                              \
6046         ) {                                                 \
6047             dOsomething;                                    \
6048             goto reStudy;                                   \
6049         }                                                   \
6050     } STMT_END
6051 #else
6052 #define CHECK_RESTUDY_GOTO_butfirst
6053 #endif
6054
6055 /*
6056  * pregcomp - compile a regular expression into internal code
6057  *
6058  * Decides which engine's compiler to call based on the hint currently in
6059  * scope
6060  */
6061
6062 #ifndef PERL_IN_XSUB_RE
6063
6064 /* return the currently in-scope regex engine (or the default if none)  */
6065
6066 regexp_engine const *
6067 Perl_current_re_engine(pTHX)
6068 {
6069     if (IN_PERL_COMPILETIME) {
6070         HV * const table = GvHV(PL_hintgv);
6071         SV **ptr;
6072
6073         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6074             return &PL_core_reg_engine;
6075         ptr = hv_fetchs(table, "regcomp", FALSE);
6076         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6077             return &PL_core_reg_engine;
6078         return INT2PTR(regexp_engine*,SvIV(*ptr));
6079     }
6080     else {
6081         SV *ptr;
6082         if (!PL_curcop->cop_hints_hash)
6083             return &PL_core_reg_engine;
6084         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6085         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6086             return &PL_core_reg_engine;
6087         return INT2PTR(regexp_engine*,SvIV(ptr));
6088     }
6089 }
6090
6091
6092 REGEXP *
6093 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6094 {
6095     regexp_engine const *eng = current_re_engine();
6096     GET_RE_DEBUG_FLAGS_DECL;
6097
6098     PERL_ARGS_ASSERT_PREGCOMP;
6099
6100     /* Dispatch a request to compile a regexp to correct regexp engine. */
6101     DEBUG_COMPILE_r({
6102         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6103                         PTR2UV(eng));
6104     });
6105     return CALLREGCOMP_ENG(eng, pattern, flags);
6106 }
6107 #endif
6108
6109 /* public(ish) entry point for the perl core's own regex compiling code.
6110  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6111  * pattern rather than a list of OPs, and uses the internal engine rather
6112  * than the current one */
6113
6114 REGEXP *
6115 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6116 {
6117     SV *pat = pattern; /* defeat constness! */
6118     PERL_ARGS_ASSERT_RE_COMPILE;
6119     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6120 #ifdef PERL_IN_XSUB_RE
6121                                 &my_reg_engine,
6122 #else
6123                                 &PL_core_reg_engine,
6124 #endif
6125                                 NULL, NULL, rx_flags, 0);
6126 }
6127
6128
6129 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6130  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6131  * point to the realloced string and length.
6132  *
6133  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6134  * stuff added */
6135
6136 static void
6137 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6138                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6139 {
6140     U8 *const src = (U8*)*pat_p;
6141     U8 *dst, *d;
6142     int n=0;
6143     STRLEN s = 0;
6144     bool do_end = 0;
6145     GET_RE_DEBUG_FLAGS_DECL;
6146
6147     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6148         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6149
6150     Newx(dst, *plen_p * 2 + 1, U8);
6151     d = dst;
6152
6153     while (s < *plen_p) {
6154         append_utf8_from_native_byte(src[s], &d);
6155         if (n < num_code_blocks) {
6156             if (!do_end && pRExC_state->code_blocks[n].start == s) {
6157                 pRExC_state->code_blocks[n].start = d - dst - 1;
6158                 assert(*(d - 1) == '(');
6159                 do_end = 1;
6160             }
6161             else if (do_end && pRExC_state->code_blocks[n].end == s) {
6162                 pRExC_state->code_blocks[n].end = d - dst - 1;
6163                 assert(*(d - 1) == ')');
6164                 do_end = 0;
6165                 n++;
6166             }
6167         }
6168         s++;
6169     }
6170     *d = '\0';
6171     *plen_p = d - dst;
6172     *pat_p = (char*) dst;
6173     SAVEFREEPV(*pat_p);
6174     RExC_orig_utf8 = RExC_utf8 = 1;
6175 }
6176
6177
6178
6179 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6180  * while recording any code block indices, and handling overloading,
6181  * nested qr// objects etc.  If pat is null, it will allocate a new
6182  * string, or just return the first arg, if there's only one.
6183  *
6184  * Returns the malloced/updated pat.
6185  * patternp and pat_count is the array of SVs to be concatted;
6186  * oplist is the optional list of ops that generated the SVs;
6187  * recompile_p is a pointer to a boolean that will be set if
6188  *   the regex will need to be recompiled.
6189  * delim, if non-null is an SV that will be inserted between each element
6190  */
6191
6192 static SV*
6193 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6194                 SV *pat, SV ** const patternp, int pat_count,
6195                 OP *oplist, bool *recompile_p, SV *delim)
6196 {
6197     SV **svp;
6198     int n = 0;
6199     bool use_delim = FALSE;
6200     bool alloced = FALSE;
6201
6202     /* if we know we have at least two args, create an empty string,
6203      * then concatenate args to that. For no args, return an empty string */
6204     if (!pat && pat_count != 1) {
6205         pat = newSVpvs("");
6206         SAVEFREESV(pat);
6207         alloced = TRUE;
6208     }
6209
6210     for (svp = patternp; svp < patternp + pat_count; svp++) {
6211         SV *sv;
6212         SV *rx  = NULL;
6213         STRLEN orig_patlen = 0;
6214         bool code = 0;
6215         SV *msv = use_delim ? delim : *svp;
6216         if (!msv) msv = &PL_sv_undef;
6217
6218         /* if we've got a delimiter, we go round the loop twice for each
6219          * svp slot (except the last), using the delimiter the second
6220          * time round */
6221         if (use_delim) {
6222             svp--;
6223             use_delim = FALSE;
6224         }
6225         else if (delim)
6226             use_delim = TRUE;
6227
6228         if (SvTYPE(msv) == SVt_PVAV) {
6229             /* we've encountered an interpolated array within
6230              * the pattern, e.g. /...@a..../. Expand the list of elements,
6231              * then recursively append elements.
6232              * The code in this block is based on S_pushav() */
6233
6234             AV *const av = (AV*)msv;
6235             const SSize_t maxarg = AvFILL(av) + 1;
6236             SV **array;
6237
6238             if (oplist) {
6239                 assert(oplist->op_type == OP_PADAV
6240                     || oplist->op_type == OP_RV2AV);
6241                 oplist = OpSIBLING(oplist);
6242             }
6243
6244             if (SvRMAGICAL(av)) {
6245                 SSize_t i;
6246
6247                 Newx(array, maxarg, SV*);
6248                 SAVEFREEPV(array);
6249                 for (i=0; i < maxarg; i++) {
6250                     SV ** const svp = av_fetch(av, i, FALSE);
6251                     array[i] = svp ? *svp : &PL_sv_undef;
6252                 }
6253             }
6254             else
6255                 array = AvARRAY(av);
6256
6257             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6258                                 array, maxarg, NULL, recompile_p,
6259                                 /* $" */
6260                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6261
6262             continue;
6263         }
6264
6265
6266         /* we make the assumption here that each op in the list of
6267          * op_siblings maps to one SV pushed onto the stack,
6268          * except for code blocks, with have both an OP_NULL and
6269          * and OP_CONST.
6270          * This allows us to match up the list of SVs against the
6271          * list of OPs to find the next code block.
6272          *
6273          * Note that       PUSHMARK PADSV PADSV ..
6274          * is optimised to
6275          *                 PADRANGE PADSV  PADSV  ..
6276          * so the alignment still works. */
6277
6278         if (oplist) {
6279             if (oplist->op_type == OP_NULL
6280                 && (oplist->op_flags & OPf_SPECIAL))
6281             {
6282                 assert(n < pRExC_state->num_code_blocks);
6283                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
6284                 pRExC_state->code_blocks[n].block = oplist;
6285                 pRExC_state->code_blocks[n].src_regex = NULL;
6286                 n++;
6287                 code = 1;
6288                 oplist = OpSIBLING(oplist); /* skip CONST */
6289                 assert(oplist);
6290             }
6291             oplist = OpSIBLING(oplist);;
6292         }
6293
6294         /* apply magic and QR overloading to arg */
6295
6296         SvGETMAGIC(msv);
6297         if (SvROK(msv) && SvAMAGIC(msv)) {
6298             SV *sv = AMG_CALLunary(msv, regexp_amg);
6299             if (sv) {
6300                 if (SvROK(sv))
6301                     sv = SvRV(sv);
6302                 if (SvTYPE(sv) != SVt_REGEXP)
6303                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6304                 msv = sv;
6305             }
6306         }
6307
6308         /* try concatenation overload ... */
6309         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6310                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6311         {
6312             sv_setsv(pat, sv);
6313             /* overloading involved: all bets are off over literal
6314              * code. Pretend we haven't seen it */
6315             pRExC_state->num_code_blocks -= n;
6316             n = 0;
6317         }
6318         else  {
6319             /* ... or failing that, try "" overload */
6320             while (SvAMAGIC(msv)
6321                     && (sv = AMG_CALLunary(msv, string_amg))
6322                     && sv != msv
6323                     &&  !(   SvROK(msv)
6324                           && SvROK(sv)
6325                           && SvRV(msv) == SvRV(sv))
6326             ) {
6327                 msv = sv;
6328                 SvGETMAGIC(msv);
6329             }
6330             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6331                 msv = SvRV(msv);
6332
6333             if (pat) {
6334                 /* this is a partially unrolled
6335                  *     sv_catsv_nomg(pat, msv);
6336                  * that allows us to adjust code block indices if
6337                  * needed */
6338                 STRLEN dlen;
6339                 char *dst = SvPV_force_nomg(pat, dlen);
6340                 orig_patlen = dlen;
6341                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6342                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6343                     sv_setpvn(pat, dst, dlen);
6344                     SvUTF8_on(pat);
6345                 }
6346                 sv_catsv_nomg(pat, msv);
6347                 rx = msv;
6348             }
6349             else {
6350                 /* We have only one SV to process, but we need to verify
6351                  * it is properly null terminated or we will fail asserts
6352                  * later. In theory we probably shouldn't get such SV's,
6353                  * but if we do we should handle it gracefully. */
6354                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) ) {
6355                     /* not a string, or a string with a trailing null */
6356                     pat = msv;
6357                 } else {
6358                     /* a string with no trailing null, we need to copy it
6359                      * so it we have a trailing null */
6360                     pat = newSVsv(msv);
6361                 }
6362             }
6363
6364             if (code)
6365                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
6366         }
6367
6368         /* extract any code blocks within any embedded qr//'s */
6369         if (rx && SvTYPE(rx) == SVt_REGEXP
6370             && RX_ENGINE((REGEXP*)rx)->op_comp)
6371         {
6372
6373             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6374             if (ri->num_code_blocks) {
6375                 int i;
6376                 /* the presence of an embedded qr// with code means
6377                  * we should always recompile: the text of the
6378                  * qr// may not have changed, but it may be a
6379                  * different closure than last time */
6380                 *recompile_p = 1;
6381                 Renew(pRExC_state->code_blocks,
6382                     pRExC_state->num_code_blocks + ri->num_code_blocks,
6383                     struct reg_code_block);
6384                 pRExC_state->num_code_blocks += ri->num_code_blocks;
6385
6386                 for (i=0; i < ri->num_code_blocks; i++) {
6387                     struct reg_code_block *src, *dst;
6388                     STRLEN offset =  orig_patlen
6389                         + ReANY((REGEXP *)rx)->pre_prefix;
6390                     assert(n < pRExC_state->num_code_blocks);
6391                     src = &ri->code_blocks[i];
6392                     dst = &pRExC_state->code_blocks[n];
6393                     dst->start      = src->start + offset;
6394                     dst->end        = src->end   + offset;
6395                     dst->block      = src->block;
6396                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6397                                             src->src_regex
6398                                                 ? src->src_regex
6399                                                 : (REGEXP*)rx);
6400                     n++;
6401                 }
6402             }
6403         }
6404     }
6405     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6406     if (alloced)
6407         SvSETMAGIC(pat);
6408
6409     return pat;
6410 }
6411
6412
6413
6414 /* see if there are any run-time code blocks in the pattern.
6415  * False positives are allowed */
6416
6417 static bool
6418 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6419                     char *pat, STRLEN plen)
6420 {
6421     int n = 0;
6422     STRLEN s;
6423     
6424     PERL_UNUSED_CONTEXT;
6425
6426     for (s = 0; s < plen; s++) {
6427         if (n < pRExC_state->num_code_blocks
6428             && s == pRExC_state->code_blocks[n].start)
6429         {
6430             s = pRExC_state->code_blocks[n].end;
6431             n++;
6432             continue;
6433         }
6434         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6435          * positives here */
6436         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6437             (pat[s+2] == '{'
6438                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6439         )
6440             return 1;
6441     }
6442     return 0;
6443 }
6444
6445 /* Handle run-time code blocks. We will already have compiled any direct
6446  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6447  * copy of it, but with any literal code blocks blanked out and
6448  * appropriate chars escaped; then feed it into
6449  *
6450  *    eval "qr'modified_pattern'"
6451  *
6452  * For example,
6453  *
6454  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6455  *
6456  * becomes
6457  *
6458  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6459  *
6460  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6461  * and merge them with any code blocks of the original regexp.
6462  *
6463  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6464  * instead, just save the qr and return FALSE; this tells our caller that
6465  * the original pattern needs upgrading to utf8.
6466  */
6467
6468 static bool
6469 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6470     char *pat, STRLEN plen)
6471 {
6472     SV *qr;
6473
6474     GET_RE_DEBUG_FLAGS_DECL;
6475
6476     if (pRExC_state->runtime_code_qr) {
6477         /* this is the second time we've been called; this should
6478          * only happen if the main pattern got upgraded to utf8
6479          * during compilation; re-use the qr we compiled first time
6480          * round (which should be utf8 too)
6481          */
6482         qr = pRExC_state->runtime_code_qr;
6483         pRExC_state->runtime_code_qr = NULL;
6484         assert(RExC_utf8 && SvUTF8(qr));
6485     }
6486     else {
6487         int n = 0;
6488         STRLEN s;
6489         char *p, *newpat;
6490         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
6491         SV *sv, *qr_ref;
6492         dSP;
6493
6494         /* determine how many extra chars we need for ' and \ escaping */
6495         for (s = 0; s < plen; s++) {
6496             if (pat[s] == '\'' || pat[s] == '\\')
6497                 newlen++;
6498         }
6499
6500         Newx(newpat, newlen, char);
6501         p = newpat;
6502         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6503
6504         for (s = 0; s < plen; s++) {
6505             if (n < pRExC_state->num_code_blocks
6506                 && s == pRExC_state->code_blocks[n].start)
6507             {
6508                 /* blank out literal code block */
6509                 assert(pat[s] == '(');
6510                 while (s <= pRExC_state->code_blocks[n].end) {
6511                     *p++ = '_';
6512                     s++;
6513                 }
6514                 s--;
6515                 n++;
6516                 continue;
6517             }
6518             if (pat[s] == '\'' || pat[s] == '\\')
6519                 *p++ = '\\';
6520             *p++ = pat[s];
6521         }
6522         *p++ = '\'';
6523         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
6524             *p++ = 'x';
6525         *p++ = '\0';
6526         DEBUG_COMPILE_r({
6527             Perl_re_printf( aTHX_
6528                 "%sre-parsing pattern for runtime code:%s %s\n",
6529                 PL_colors[4],PL_colors[5],newpat);
6530         });
6531
6532         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6533         Safefree(newpat);
6534
6535         ENTER;
6536         SAVETMPS;
6537         save_re_context();
6538         PUSHSTACKi(PERLSI_REQUIRE);
6539         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6540          * parsing qr''; normally only q'' does this. It also alters
6541          * hints handling */
6542         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6543         SvREFCNT_dec_NN(sv);
6544         SPAGAIN;
6545         qr_ref = POPs;
6546         PUTBACK;
6547         {
6548             SV * const errsv = ERRSV;
6549             if (SvTRUE_NN(errsv))
6550             {
6551                 Safefree(pRExC_state->code_blocks);
6552                 /* use croak_sv ? */
6553                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
6554             }
6555         }
6556         assert(SvROK(qr_ref));
6557         qr = SvRV(qr_ref);
6558         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6559         /* the leaving below frees the tmp qr_ref.
6560          * Give qr a life of its own */
6561         SvREFCNT_inc(qr);
6562         POPSTACK;
6563         FREETMPS;
6564         LEAVE;
6565
6566     }
6567
6568     if (!RExC_utf8 && SvUTF8(qr)) {
6569         /* first time through; the pattern got upgraded; save the
6570          * qr for the next time through */
6571         assert(!pRExC_state->runtime_code_qr);
6572         pRExC_state->runtime_code_qr = qr;
6573         return 0;
6574     }
6575
6576
6577     /* extract any code blocks within the returned qr//  */
6578
6579
6580     /* merge the main (r1) and run-time (r2) code blocks into one */
6581     {
6582         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6583         struct reg_code_block *new_block, *dst;
6584         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6585         int i1 = 0, i2 = 0;
6586
6587         if (!r2->num_code_blocks) /* we guessed wrong */
6588         {
6589             SvREFCNT_dec_NN(qr);
6590             return 1;
6591         }
6592
6593         Newx(new_block,
6594             r1->num_code_blocks + r2->num_code_blocks,
6595             struct reg_code_block);
6596         dst = new_block;
6597
6598         while (    i1 < r1->num_code_blocks
6599                 || i2 < r2->num_code_blocks)
6600         {
6601             struct reg_code_block *src;
6602             bool is_qr = 0;
6603
6604             if (i1 == r1->num_code_blocks) {
6605                 src = &r2->code_blocks[i2++];
6606                 is_qr = 1;
6607             }
6608             else if (i2 == r2->num_code_blocks)
6609                 src = &r1->code_blocks[i1++];
6610             else if (  r1->code_blocks[i1].start
6611                      < r2->code_blocks[i2].start)
6612             {
6613                 src = &r1->code_blocks[i1++];
6614                 assert(src->end < r2->code_blocks[i2].start);
6615             }
6616             else {
6617                 assert(  r1->code_blocks[i1].start
6618                        > r2->code_blocks[i2].start);
6619                 src = &r2->code_blocks[i2++];
6620                 is_qr = 1;
6621                 assert(src->end < r1->code_blocks[i1].start);
6622             }
6623
6624             assert(pat[src->start] == '(');
6625             assert(pat[src->end]   == ')');
6626             dst->start      = src->start;
6627             dst->end        = src->end;
6628             dst->block      = src->block;
6629             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6630                                     : src->src_regex;
6631             dst++;
6632         }
6633         r1->num_code_blocks += r2->num_code_blocks;
6634         Safefree(r1->code_blocks);
6635         r1->code_blocks = new_block;
6636     }
6637
6638     SvREFCNT_dec_NN(qr);
6639     return 1;
6640 }
6641
6642
6643 STATIC bool
6644 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6645                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6646                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6647                       STRLEN longest_length, bool eol, bool meol)
6648 {
6649     /* This is the common code for setting up the floating and fixed length
6650      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6651      * as to whether succeeded or not */
6652
6653     I32 t;
6654     SSize_t ml;
6655
6656     if (! (longest_length
6657            || (eol /* Can't have SEOL and MULTI */
6658                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6659           )
6660             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6661         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6662     {
6663         return FALSE;
6664     }
6665
6666     /* copy the information about the longest from the reg_scan_data
6667         over to the program. */
6668     if (SvUTF8(sv_longest)) {
6669         *rx_utf8 = sv_longest;
6670         *rx_substr = NULL;
6671     } else {
6672         *rx_substr = sv_longest;
6673         *rx_utf8 = NULL;
6674     }
6675     /* end_shift is how many chars that must be matched that
6676         follow this item. We calculate it ahead of time as once the
6677         lookbehind offset is added in we lose the ability to correctly
6678         calculate it.*/
6679     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6680     *rx_end_shift = ml - offset
6681         - longest_length
6682             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
6683              * intead? - DAPM
6684             + (SvTAIL(sv_longest) != 0)
6685             */
6686         + lookbehind;
6687
6688     t = (eol/* Can't have SEOL and MULTI */
6689          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6690     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6691
6692     return TRUE;
6693 }
6694
6695 /*
6696  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6697  * regular expression into internal code.
6698  * The pattern may be passed either as:
6699  *    a list of SVs (patternp plus pat_count)
6700  *    a list of OPs (expr)
6701  * If both are passed, the SV list is used, but the OP list indicates
6702  * which SVs are actually pre-compiled code blocks
6703  *
6704  * The SVs in the list have magic and qr overloading applied to them (and
6705  * the list may be modified in-place with replacement SVs in the latter
6706  * case).
6707  *
6708  * If the pattern hasn't changed from old_re, then old_re will be
6709  * returned.
6710  *
6711  * eng is the current engine. If that engine has an op_comp method, then
6712  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6713  * do the initial concatenation of arguments and pass on to the external
6714  * engine.
6715  *
6716  * If is_bare_re is not null, set it to a boolean indicating whether the
6717  * arg list reduced (after overloading) to a single bare regex which has
6718  * been returned (i.e. /$qr/).
6719  *
6720  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6721  *
6722  * pm_flags contains the PMf_* flags, typically based on those from the
6723  * pm_flags field of the related PMOP. Currently we're only interested in
6724  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6725  *
6726  * We can't allocate space until we know how big the compiled form will be,
6727  * but we can't compile it (and thus know how big it is) until we've got a
6728  * place to put the code.  So we cheat:  we compile it twice, once with code
6729  * generation turned off and size counting turned on, and once "for real".
6730  * This also means that we don't allocate space until we are sure that the
6731  * thing really will compile successfully, and we never have to move the
6732  * code and thus invalidate pointers into it.  (Note that it has to be in
6733  * one piece because free() must be able to free it all.) [NB: not true in perl]
6734  *
6735  * Beware that the optimization-preparation code in here knows about some
6736  * of the structure of the compiled regexp.  [I'll say.]
6737  */
6738
6739 REGEXP *
6740 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6741                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6742                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6743 {
6744     REGEXP *rx;
6745     struct regexp *r;
6746     regexp_internal *ri;
6747     STRLEN plen;
6748     char *exp;
6749     regnode *scan;
6750     I32 flags;
6751     SSize_t minlen = 0;
6752     U32 rx_flags;
6753     SV *pat;
6754     SV *code_blocksv = NULL;
6755     SV** new_patternp = patternp;
6756
6757     /* these are all flags - maybe they should be turned
6758      * into a single int with different bit masks */
6759     I32 sawlookahead = 0;
6760     I32 sawplus = 0;
6761     I32 sawopen = 0;
6762     I32 sawminmod = 0;
6763
6764     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6765     bool recompile = 0;
6766     bool runtime_code = 0;
6767     scan_data_t data;
6768     RExC_state_t RExC_state;
6769     RExC_state_t * const pRExC_state = &RExC_state;
6770 #ifdef TRIE_STUDY_OPT
6771     int restudied = 0;
6772     RExC_state_t copyRExC_state;
6773 #endif
6774     GET_RE_DEBUG_FLAGS_DECL;
6775
6776     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6777
6778     DEBUG_r(if (!PL_colorset) reginitcolors());
6779
6780     /* Initialize these here instead of as-needed, as is quick and avoids
6781      * having to test them each time otherwise */
6782     if (! PL_AboveLatin1) {
6783 #ifdef DEBUGGING
6784         char * dump_len_string;
6785 #endif
6786
6787         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6788         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6789         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6790         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6791         PL_HasMultiCharFold =
6792                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6793
6794         /* This is calculated here, because the Perl program that generates the
6795          * static global ones doesn't currently have access to
6796          * NUM_ANYOF_CODE_POINTS */
6797         PL_InBitmap = _new_invlist(2);
6798         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6799                                                     NUM_ANYOF_CODE_POINTS - 1);
6800 #ifdef DEBUGGING
6801         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6802         if (   ! dump_len_string
6803             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6804         {
6805             PL_dump_re_max_len = 0;
6806         }
6807 #endif
6808     }
6809
6810     pRExC_state->warn_text = NULL;
6811     pRExC_state->code_blocks = NULL;
6812     pRExC_state->num_code_blocks = 0;
6813
6814     if (is_bare_re)
6815         *is_bare_re = FALSE;
6816
6817     if (expr && (expr->op_type == OP_LIST ||
6818                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6819         /* allocate code_blocks if needed */
6820         OP *o;
6821         int ncode = 0;
6822
6823         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6824             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6825                 ncode++; /* count of DO blocks */
6826         if (ncode) {
6827             pRExC_state->num_code_blocks = ncode;
6828             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
6829         }
6830     }
6831
6832     if (!pat_count) {
6833         /* compile-time pattern with just OP_CONSTs and DO blocks */
6834
6835         int n;
6836         OP *o;
6837
6838         /* find how many CONSTs there are */
6839         assert(expr);
6840         n = 0;
6841         if (expr->op_type == OP_CONST)
6842             n = 1;
6843         else
6844             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6845                 if (o->op_type == OP_CONST)
6846                     n++;
6847             }
6848
6849         /* fake up an SV array */
6850
6851         assert(!new_patternp);
6852         Newx(new_patternp, n, SV*);
6853         SAVEFREEPV(new_patternp);
6854         pat_count = n;
6855
6856         n = 0;
6857         if (expr->op_type == OP_CONST)
6858             new_patternp[n] = cSVOPx_sv(expr);
6859         else
6860             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6861                 if (o->op_type == OP_CONST)
6862                     new_patternp[n++] = cSVOPo_sv;
6863             }
6864
6865     }
6866
6867     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6868         "Assembling pattern from %d elements%s\n", pat_count,
6869             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6870
6871     /* set expr to the first arg op */
6872
6873     if (pRExC_state->num_code_blocks
6874          && expr->op_type != OP_CONST)
6875     {
6876             expr = cLISTOPx(expr)->op_first;
6877             assert(   expr->op_type == OP_PUSHMARK
6878                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6879                    || expr->op_type == OP_PADRANGE);
6880             expr = OpSIBLING(expr);
6881     }
6882
6883     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6884                         expr, &recompile, NULL);
6885
6886     /* handle bare (possibly after overloading) regex: foo =~ $re */
6887     {
6888         SV *re = pat;
6889         if (SvROK(re))
6890             re = SvRV(re);
6891         if (SvTYPE(re) == SVt_REGEXP) {
6892             if (is_bare_re)
6893                 *is_bare_re = TRUE;
6894             SvREFCNT_inc(re);
6895             Safefree(pRExC_state->code_blocks);
6896             DEBUG_PARSE_r(Perl_re_printf( aTHX_
6897                 "Precompiled pattern%s\n",
6898                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6899
6900             return (REGEXP*)re;
6901         }
6902     }
6903
6904     exp = SvPV_nomg(pat, plen);
6905
6906     if (!eng->op_comp) {
6907         if ((SvUTF8(pat) && IN_BYTES)
6908                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6909         {
6910             /* make a temporary copy; either to convert to bytes,
6911              * or to avoid repeating get-magic / overloaded stringify */
6912             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6913                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6914         }
6915         Safefree(pRExC_state->code_blocks);
6916         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6917     }
6918
6919     /* ignore the utf8ness if the pattern is 0 length */
6920     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6921
6922     RExC_uni_semantics = 0;
6923     RExC_seen_unfolded_sharp_s = 0;
6924     RExC_contains_locale = 0;
6925     RExC_contains_i = 0;
6926     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
6927     RExC_study_started = 0;
6928     pRExC_state->runtime_code_qr = NULL;
6929     RExC_frame_head= NULL;
6930     RExC_frame_last= NULL;
6931     RExC_frame_count= 0;
6932
6933     DEBUG_r({
6934         RExC_mysv1= sv_newmortal();
6935         RExC_mysv2= sv_newmortal();
6936     });
6937     DEBUG_COMPILE_r({
6938             SV *dsv= sv_newmortal();
6939             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6940             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
6941                           PL_colors[4],PL_colors[5],s);
6942         });
6943
6944   redo_first_pass:
6945     /* we jump here if we have to recompile, e.g., from upgrading the pattern
6946      * to utf8 */
6947
6948     if ((pm_flags & PMf_USE_RE_EVAL)
6949                 /* this second condition covers the non-regex literal case,
6950                  * i.e.  $foo =~ '(?{})'. */
6951                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6952     )
6953         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6954
6955     /* return old regex if pattern hasn't changed */
6956     /* XXX: note in the below we have to check the flags as well as the
6957      * pattern.
6958      *
6959      * Things get a touch tricky as we have to compare the utf8 flag
6960      * independently from the compile flags.  */
6961
6962     if (   old_re
6963         && !recompile
6964         && !!RX_UTF8(old_re) == !!RExC_utf8
6965         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
6966         && RX_PRECOMP(old_re)
6967         && RX_PRELEN(old_re) == plen
6968         && memEQ(RX_PRECOMP(old_re), exp, plen)
6969         && !runtime_code /* with runtime code, always recompile */ )
6970     {
6971         Safefree(pRExC_state->code_blocks);
6972         return old_re;
6973     }
6974
6975     rx_flags = orig_rx_flags;
6976
6977     if (rx_flags & PMf_FOLD) {
6978         RExC_contains_i = 1;
6979     }
6980     if (   initial_charset == REGEX_DEPENDS_CHARSET
6981         && (RExC_utf8 ||RExC_uni_semantics))
6982     {
6983
6984         /* Set to use unicode semantics if the pattern is in utf8 and has the
6985          * 'depends' charset specified, as it means unicode when utf8  */
6986         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6987     }
6988
6989     RExC_precomp = exp;
6990     RExC_precomp_adj = 0;
6991     RExC_flags = rx_flags;
6992     RExC_pm_flags = pm_flags;
6993
6994     if (runtime_code) {
6995         assert(TAINTING_get || !TAINT_get);
6996         if (TAINT_get)
6997             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
6998
6999         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7000             /* whoops, we have a non-utf8 pattern, whilst run-time code
7001              * got compiled as utf8. Try again with a utf8 pattern */
7002             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7003                                     pRExC_state->num_code_blocks);
7004             goto redo_first_pass;
7005         }
7006     }
7007     assert(!pRExC_state->runtime_code_qr);
7008
7009     RExC_sawback = 0;
7010
7011     RExC_seen = 0;
7012     RExC_maxlen = 0;
7013     RExC_in_lookbehind = 0;
7014     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7015     RExC_extralen = 0;
7016     RExC_override_recoding = 0;
7017 #ifdef EBCDIC
7018     RExC_recode_x_to_native = 0;
7019 #endif
7020     RExC_in_multi_char_class = 0;
7021
7022     /* First pass: determine size, legality. */
7023     RExC_parse = exp;
7024     RExC_start = RExC_adjusted_start = exp;
7025     RExC_end = exp + plen;
7026     RExC_precomp_end = RExC_end;
7027     RExC_naughty = 0;
7028     RExC_npar = 1;
7029     RExC_nestroot = 0;
7030     RExC_size = 0L;
7031     RExC_emit = (regnode *) &RExC_emit_dummy;
7032     RExC_whilem_seen = 0;
7033     RExC_open_parens = NULL;
7034     RExC_close_parens = NULL;
7035     RExC_end_op = NULL;
7036     RExC_paren_names = NULL;
7037 #ifdef DEBUGGING
7038     RExC_paren_name_list = NULL;
7039 #endif
7040     RExC_recurse = NULL;
7041     RExC_study_chunk_recursed = NULL;
7042     RExC_study_chunk_recursed_bytes= 0;
7043     RExC_recurse_count = 0;
7044     pRExC_state->code_index = 0;
7045
7046     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7047      * code makes sure the final byte is an uncounted NUL.  But should this
7048      * ever not be the case, lots of things could read beyond the end of the
7049      * buffer: loops like
7050      *      while(isFOO(*RExC_parse)) RExC_parse++;
7051      *      strchr(RExC_parse, "foo");
7052      * etc.  So it is worth noting. */
7053     assert(*RExC_end == '\0');
7054
7055     DEBUG_PARSE_r(
7056         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7057         RExC_lastnum=0;
7058         RExC_lastparse=NULL;
7059     );
7060     /* reg may croak on us, not giving us a chance to free
7061        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
7062        need it to survive as long as the regexp (qr/(?{})/).
7063        We must check that code_blocksv is not already set, because we may
7064        have jumped back to restart the sizing pass. */
7065     if (pRExC_state->code_blocks && !code_blocksv) {
7066         code_blocksv = newSV_type(SVt_PV);
7067         SAVEFREESV(code_blocksv);
7068         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
7069         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
7070     }
7071     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7072         /* It's possible to write a regexp in ascii that represents Unicode
7073         codepoints outside of the byte range, such as via \x{100}. If we
7074         detect such a sequence we have to convert the entire pattern to utf8
7075         and then recompile, as our sizing calculation will have been based
7076         on 1 byte == 1 character, but we will need to use utf8 to encode
7077         at least some part of the pattern, and therefore must convert the whole
7078         thing.
7079         -- dmq */
7080         if (flags & RESTART_PASS1) {
7081             if (flags & NEED_UTF8) {
7082                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7083                                     pRExC_state->num_code_blocks);
7084             }
7085             else {
7086                 DEBUG_PARSE_r(Perl_re_printf( aTHX_
7087                 "Need to redo pass 1\n"));
7088             }
7089
7090             goto redo_first_pass;
7091         }
7092         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
7093     }
7094     if (code_blocksv)
7095         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
7096
7097     DEBUG_PARSE_r({
7098         Perl_re_printf( aTHX_
7099             "Required size %" IVdf " nodes\n"
7100             "Starting second pass (creation)\n",
7101             (IV)RExC_size);
7102         RExC_lastnum=0;
7103         RExC_lastparse=NULL;
7104     });
7105
7106     /* The first pass could have found things that force Unicode semantics */
7107     if ((RExC_utf8 || RExC_uni_semantics)
7108          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7109     {
7110         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7111     }
7112
7113     /* Small enough for pointer-storage convention?
7114        If extralen==0, this means that we will not need long jumps. */
7115     if (RExC_size >= 0x10000L && RExC_extralen)
7116         RExC_size += RExC_extralen;
7117     else
7118         RExC_extralen = 0;
7119     if (RExC_whilem_seen > 15)
7120         RExC_whilem_seen = 15;
7121
7122     /* Allocate space and zero-initialize. Note, the two step process
7123        of zeroing when in debug mode, thus anything assigned has to
7124        happen after that */
7125     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7126     r = ReANY(rx);
7127     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7128          char, regexp_internal);
7129     if ( r == NULL || ri == NULL )
7130         FAIL("Regexp out of space");
7131 #ifdef DEBUGGING
7132     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7133     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7134          char);
7135 #else
7136     /* bulk initialize base fields with 0. */
7137     Zero(ri, sizeof(regexp_internal), char);
7138 #endif
7139
7140     /* non-zero initialization begins here */
7141     RXi_SET( r, ri );
7142     r->engine= eng;
7143     r->extflags = rx_flags;
7144     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7145
7146     if (pm_flags & PMf_IS_QR) {
7147         ri->code_blocks = pRExC_state->code_blocks;
7148         ri->num_code_blocks = pRExC_state->num_code_blocks;
7149     }
7150     else
7151     {
7152         int n;
7153         for (n = 0; n < pRExC_state->num_code_blocks; n++)
7154             if (pRExC_state->code_blocks[n].src_regex)
7155                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
7156         if(pRExC_state->code_blocks)
7157             SAVEFREEPV(pRExC_state->code_blocks); /* often null */
7158     }
7159
7160     {
7161         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7162         bool has_charset = (get_regex_charset(r->extflags)
7163                                                     != REGEX_DEPENDS_CHARSET);
7164
7165         /* The caret is output if there are any defaults: if not all the STD
7166          * flags are set, or if no character set specifier is needed */
7167         bool has_default =
7168                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7169                     || ! has_charset);
7170         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7171                                                    == REG_RUN_ON_COMMENT_SEEN);
7172         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7173                             >> RXf_PMf_STD_PMMOD_SHIFT);
7174         const char *fptr = STD_PAT_MODS;        /*"msixn"*/
7175         char *p;
7176
7177         /* We output all the necessary flags; we never output a minus, as all
7178          * those are defaults, so are
7179          * covered by the caret */
7180         const STRLEN wraplen = plen + has_p + has_runon
7181             + has_default       /* If needs a caret */
7182             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7183
7184                 /* If needs a character set specifier */
7185             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7186             + (sizeof("(?:)") - 1);
7187
7188         /* make sure PL_bitcount bounds not exceeded */
7189         assert(sizeof(STD_PAT_MODS) <= 8);
7190
7191         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
7192         r->xpv_len_u.xpvlenu_pv = p;
7193         if (RExC_utf8)
7194             SvFLAGS(rx) |= SVf_UTF8;
7195         *p++='('; *p++='?';
7196
7197         /* If a default, cover it using the caret */
7198         if (has_default) {
7199             *p++= DEFAULT_PAT_MOD;
7200         }
7201         if (has_charset) {
7202             STRLEN len;
7203             const char* const name = get_regex_charset_name(r->extflags, &len);
7204             Copy(name, p, len, char);
7205             p += len;
7206         }
7207         if (has_p)
7208             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7209         {
7210             char ch;
7211             while((ch = *fptr++)) {
7212                 if(reganch & 1)
7213                     *p++ = ch;
7214                 reganch >>= 1;
7215             }
7216         }
7217
7218         *p++ = ':';
7219         Copy(RExC_precomp, p, plen, char);
7220         assert ((RX_WRAPPED(rx) - p) < 16);
7221         r->pre_prefix = p - RX_WRAPPED(rx);
7222         p += plen;
7223         if (has_runon)
7224             *p++ = '\n';
7225         *p++ = ')';
7226         *p = 0;
7227         SvCUR_set(rx, p - RX_WRAPPED(rx));
7228     }
7229
7230     r->intflags = 0;
7231     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7232
7233     /* Useful during FAIL. */
7234 #ifdef RE_TRACK_PATTERN_OFFSETS
7235     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7236     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7237                           "%s %" UVuf " bytes for offset annotations.\n",
7238                           ri->u.offsets ? "Got" : "Couldn't get",
7239                           (UV)((2*RExC_size+1) * sizeof(U32))));
7240 #endif
7241     SetProgLen(ri,RExC_size);
7242     RExC_rx_sv = rx;
7243     RExC_rx = r;
7244     RExC_rxi = ri;
7245
7246     /* Second pass: emit code. */
7247     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7248     RExC_pm_flags = pm_flags;
7249     RExC_parse = exp;
7250     RExC_end = exp + plen;
7251     RExC_naughty = 0;
7252     RExC_emit_start = ri->program;
7253     RExC_emit = ri->program;
7254     RExC_emit_bound = ri->program + RExC_size + 1;
7255     pRExC_state->code_index = 0;
7256
7257     *((char*) RExC_emit++) = (char) REG_MAGIC;
7258     /* setup various meta data about recursion, this all requires
7259      * RExC_npar to be correctly set, and a bit later on we clear it */
7260     if (RExC_seen & REG_RECURSE_SEEN) {
7261         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7262             "%*s%*s Setting up open/close parens\n",
7263                   22, "|    |", (int)(0 * 2 + 1), ""));
7264
7265         /* setup RExC_open_parens, which holds the address of each
7266          * OPEN tag, and to make things simpler for the 0 index
7267          * the start of the program - this is used later for offsets */
7268         Newxz(RExC_open_parens, RExC_npar,regnode *);
7269         SAVEFREEPV(RExC_open_parens);
7270         RExC_open_parens[0] = RExC_emit;
7271
7272         /* setup RExC_close_parens, which holds the address of each
7273          * CLOSE tag, and to make things simpler for the 0 index
7274          * the end of the program - this is used later for offsets */
7275         Newxz(RExC_close_parens, RExC_npar,regnode *);
7276         SAVEFREEPV(RExC_close_parens);
7277         /* we dont know where end op starts yet, so we dont
7278          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7279
7280         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7281          * So its 1 if there are no parens. */
7282         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7283                                          ((RExC_npar & 0x07) != 0);
7284         Newx(RExC_study_chunk_recursed,
7285              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7286         SAVEFREEPV(RExC_study_chunk_recursed);
7287     }
7288     RExC_npar = 1;
7289     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7290         ReREFCNT_dec(rx);
7291         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#" UVxf, (UV) flags);
7292     }
7293     DEBUG_OPTIMISE_r(
7294         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7295     );
7296
7297     /* XXXX To minimize changes to RE engine we always allocate
7298        3-units-long substrs field. */
7299     Newx(r->substrs, 1, struct reg_substr_data);
7300     if (RExC_recurse_count) {
7301         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
7302         SAVEFREEPV(RExC_recurse);
7303     }
7304
7305   reStudy:
7306     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7307     DEBUG_r(
7308         RExC_study_chunk_recursed_count= 0;
7309     );
7310     Zero(r->substrs, 1, struct reg_substr_data);
7311     if (RExC_study_chunk_recursed) {
7312         Zero(RExC_study_chunk_recursed,
7313              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7314     }
7315
7316
7317 #ifdef TRIE_STUDY_OPT
7318     if (!restudied) {
7319         StructCopy(&zero_scan_data, &data, scan_data_t);
7320         copyRExC_state = RExC_state;
7321     } else {
7322         U32 seen=RExC_seen;
7323         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7324
7325         RExC_state = copyRExC_state;
7326         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7327             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7328         else
7329             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7330         StructCopy(&zero_scan_data, &data, scan_data_t);
7331     }
7332 #else
7333     StructCopy(&zero_scan_data, &data, scan_data_t);
7334 #endif
7335
7336     /* Dig out information for optimizations. */
7337     r->extflags = RExC_flags; /* was pm_op */
7338     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7339
7340     if (UTF)
7341         SvUTF8_on(rx);  /* Unicode in it? */
7342     ri->regstclass = NULL;
7343     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7344         r->intflags |= PREGf_NAUGHTY;
7345     scan = ri->program + 1;             /* First BRANCH. */
7346
7347     /* testing for BRANCH here tells us whether there is "must appear"
7348        data in the pattern. If there is then we can use it for optimisations */
7349     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7350                                                   */
7351         SSize_t fake;
7352         STRLEN longest_float_length, longest_fixed_length;
7353         regnode_ssc ch_class; /* pointed to by data */
7354         int stclass_flag;
7355         SSize_t last_close = 0; /* pointed to by data */
7356         regnode *first= scan;
7357         regnode *first_next= regnext(first);
7358         /*
7359          * Skip introductions and multiplicators >= 1
7360          * so that we can extract the 'meat' of the pattern that must
7361          * match in the large if() sequence following.
7362          * NOTE that EXACT is NOT covered here, as it is normally
7363          * picked up by the optimiser separately.
7364          *
7365          * This is unfortunate as the optimiser isnt handling lookahead
7366          * properly currently.
7367          *
7368          */
7369         while ((OP(first) == OPEN && (sawopen = 1)) ||
7370                /* An OR of *one* alternative - should not happen now. */
7371             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7372             /* for now we can't handle lookbehind IFMATCH*/
7373             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7374             (OP(first) == PLUS) ||
7375             (OP(first) == MINMOD) ||
7376                /* An {n,m} with n>0 */
7377             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7378             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7379         {
7380                 /*
7381                  * the only op that could be a regnode is PLUS, all the rest
7382                  * will be regnode_1 or regnode_2.
7383                  *
7384                  * (yves doesn't think this is true)
7385                  */
7386                 if (OP(first) == PLUS)
7387                     sawplus = 1;
7388                 else {
7389                     if (OP(first) == MINMOD)
7390                         sawminmod = 1;
7391                     first += regarglen[OP(first)];
7392                 }
7393                 first = NEXTOPER(first);
7394                 first_next= regnext(first);
7395         }
7396
7397         /* Starting-point info. */
7398       again:
7399         DEBUG_PEEP("first:",first,0);
7400         /* Ignore EXACT as we deal with it later. */
7401         if (PL_regkind[OP(first)] == EXACT) {
7402             if (OP(first) == EXACT || OP(first) == EXACTL)
7403                 NOOP;   /* Empty, get anchored substr later. */
7404             else
7405                 ri->regstclass = first;
7406         }
7407 #ifdef TRIE_STCLASS
7408         else if (PL_regkind[OP(first)] == TRIE &&
7409                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7410         {
7411             /* this can happen only on restudy */
7412             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7413         }
7414 #endif
7415         else if (REGNODE_SIMPLE(OP(first)))
7416             ri->regstclass = first;
7417         else if (PL_regkind[OP(first)] == BOUND ||
7418                  PL_regkind[OP(first)] == NBOUND)
7419             ri->regstclass = first;
7420         else if (PL_regkind[OP(first)] == BOL) {
7421             r->intflags |= (OP(first) == MBOL
7422                            ? PREGf_ANCH_MBOL
7423                            : PREGf_ANCH_SBOL);
7424             first = NEXTOPER(first);
7425             goto again;
7426         }
7427         else if (OP(first) == GPOS) {
7428             r->intflags |= PREGf_ANCH_GPOS;
7429             first = NEXTOPER(first);
7430             goto again;
7431         }
7432         else if ((!sawopen || !RExC_sawback) &&
7433             !sawlookahead &&
7434             (OP(first) == STAR &&
7435             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7436             !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
7437         {
7438             /* turn .* into ^.* with an implied $*=1 */
7439             const int type =
7440                 (OP(NEXTOPER(first)) == REG_ANY)
7441                     ? PREGf_ANCH_MBOL
7442                     : PREGf_ANCH_SBOL;
7443             r->intflags |= (type | PREGf_IMPLICIT);
7444             first = NEXTOPER(first);
7445             goto again;
7446         }
7447         if (sawplus && !sawminmod && !sawlookahead
7448             && (!sawopen || !RExC_sawback)
7449             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
7450             /* x+ must match at the 1st pos of run of x's */
7451             r->intflags |= PREGf_SKIP;
7452
7453         /* Scan is after the zeroth branch, first is atomic matcher. */
7454 #ifdef TRIE_STUDY_OPT
7455         DEBUG_PARSE_r(
7456             if (!restudied)
7457                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7458                               (IV)(first - scan + 1))
7459         );
7460 #else
7461         DEBUG_PARSE_r(
7462             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7463                 (IV)(first - scan + 1))
7464         );
7465 #endif
7466
7467
7468         /*
7469         * If there's something expensive in the r.e., find the
7470         * longest literal string that must appear and make it the
7471         * regmust.  Resolve ties in favor of later strings, since
7472         * the regstart check works with the beginning of the r.e.
7473         * and avoiding duplication strengthens checking.  Not a
7474         * strong reason, but sufficient in the absence of others.
7475         * [Now we resolve ties in favor of the earlier string if
7476         * it happens that c_offset_min has been invalidated, since the
7477         * earlier string may buy us something the later one won't.]
7478         */
7479
7480         data.longest_fixed = newSVpvs("");
7481         data.longest_float = newSVpvs("");
7482         data.last_found = newSVpvs("");
7483         data.longest = &(data.longest_fixed);
7484         ENTER_with_name("study_chunk");
7485         SAVEFREESV(data.longest_fixed);
7486         SAVEFREESV(data.longest_float);
7487         SAVEFREESV(data.last_found);
7488         first = scan;
7489         if (!ri->regstclass) {
7490             ssc_init(pRExC_state, &ch_class);
7491             data.start_class = &ch_class;
7492             stclass_flag = SCF_DO_STCLASS_AND;
7493         } else                          /* XXXX Check for BOUND? */
7494             stclass_flag = 0;
7495         data.last_closep = &last_close;
7496
7497         DEBUG_RExC_seen();
7498         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7499                              scan + RExC_size, /* Up to end */
7500             &data, -1, 0, NULL,
7501             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7502                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7503             0);
7504
7505
7506         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7507
7508
7509         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
7510              && data.last_start_min == 0 && data.last_end > 0
7511              && !RExC_seen_zerolen
7512              && !(RExC_seen & REG_VERBARG_SEEN)
7513              && !(RExC_seen & REG_GPOS_SEEN)
7514         ){
7515             r->extflags |= RXf_CHECK_ALL;
7516         }
7517         scan_commit(pRExC_state, &data,&minlen,0);
7518
7519         longest_float_length = CHR_SVLEN(data.longest_float);
7520
7521         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
7522                    && data.offset_fixed == data.offset_float_min
7523                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
7524             && S_setup_longest (aTHX_ pRExC_state,
7525                                     data.longest_float,
7526                                     &(r->float_utf8),
7527                                     &(r->float_substr),
7528                                     &(r->float_end_shift),
7529                                     data.lookbehind_float,
7530                                     data.offset_float_min,
7531                                     data.minlen_float,
7532                                     longest_float_length,
7533                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
7534                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
7535         {
7536             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
7537             r->float_max_offset = data.offset_float_max;
7538             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
7539                 r->float_max_offset -= data.lookbehind_float;
7540             SvREFCNT_inc_simple_void_NN(data.longest_float);
7541         }
7542         else {
7543             r->float_substr = r->float_utf8 = NULL;
7544             longest_float_length = 0;
7545         }
7546
7547         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
7548
7549         if (S_setup_longest (aTHX_ pRExC_state,
7550                                 data.longest_fixed,
7551                                 &(r->anchored_utf8),
7552                                 &(r->anchored_substr),
7553                                 &(r->anchored_end_shift),
7554                                 data.lookbehind_fixed,
7555                                 data.offset_fixed,
7556                                 data.minlen_fixed,
7557                                 longest_fixed_length,
7558                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7559                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7560         {
7561             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7562             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7563         }
7564         else {
7565             r->anchored_substr = r->anchored_utf8 = NULL;
7566             longest_fixed_length = 0;
7567         }
7568         LEAVE_with_name("study_chunk");
7569
7570         if (ri->regstclass
7571             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7572             ri->regstclass = NULL;
7573
7574         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7575             && stclass_flag
7576             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7577             && is_ssc_worth_it(pRExC_state, data.start_class))
7578         {
7579             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7580
7581             ssc_finalize(pRExC_state, data.start_class);
7582
7583             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7584             StructCopy(data.start_class,
7585                        (regnode_ssc*)RExC_rxi->data->data[n],
7586                        regnode_ssc);
7587             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7588             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7589             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7590                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7591                       Perl_re_printf( aTHX_
7592                                     "synthetic stclass \"%s\".\n",
7593                                     SvPVX_const(sv));});
7594             data.start_class = NULL;
7595         }
7596
7597         /* A temporary algorithm prefers floated substr to fixed one to dig
7598          * more info. */
7599         if (longest_fixed_length > longest_float_length) {
7600             r->substrs->check_ix = 0;
7601             r->check_end_shift = r->anchored_end_shift;
7602             r->check_substr = r->anchored_substr;
7603             r->check_utf8 = r->anchored_utf8;
7604             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7605             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7606                 r->intflags |= PREGf_NOSCAN;
7607         }
7608         else {
7609             r->substrs->check_ix = 1;
7610             r->check_end_shift = r->float_end_shift;
7611             r->check_substr = r->float_substr;
7612             r->check_utf8 = r->float_utf8;
7613             r->check_offset_min = r->float_min_offset;
7614             r->check_offset_max = r->float_max_offset;
7615         }
7616         if ((r->check_substr || r->check_utf8) ) {
7617             r->extflags |= RXf_USE_INTUIT;
7618             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7619                 r->extflags |= RXf_INTUIT_TAIL;
7620         }
7621         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7622
7623         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7624         if ( (STRLEN)minlen < longest_float_length )
7625             minlen= longest_float_length;
7626         if ( (STRLEN)minlen < longest_fixed_length )
7627             minlen= longest_fixed_length;
7628         */
7629     }
7630     else {
7631         /* Several toplevels. Best we can is to set minlen. */
7632         SSize_t fake;
7633         regnode_ssc ch_class;
7634         SSize_t last_close = 0;
7635
7636         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7637
7638         scan = ri->program + 1;
7639         ssc_init(pRExC_state, &ch_class);
7640         data.start_class = &ch_class;
7641         data.last_closep = &last_close;
7642
7643         DEBUG_RExC_seen();
7644         minlen = study_chunk(pRExC_state,
7645             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7646             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7647                                                       ? SCF_TRIE_DOING_RESTUDY
7648                                                       : 0),
7649             0);
7650
7651         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7652
7653         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7654                 = r->float_substr = r->float_utf8 = NULL;
7655
7656         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7657             && is_ssc_worth_it(pRExC_state, data.start_class))
7658         {
7659             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7660
7661             ssc_finalize(pRExC_state, data.start_class);
7662
7663             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7664             StructCopy(data.start_class,
7665                        (regnode_ssc*)RExC_rxi->data->data[n],
7666                        regnode_ssc);
7667             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7668             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7669             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7670                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7671                       Perl_re_printf( aTHX_
7672                                     "synthetic stclass \"%s\".\n",
7673                                     SvPVX_const(sv));});
7674             data.start_class = NULL;
7675         }
7676     }
7677
7678     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7679         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7680         r->maxlen = REG_INFTY;
7681     }
7682     else {
7683         r->maxlen = RExC_maxlen;
7684     }
7685
7686     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7687        the "real" pattern. */
7688     DEBUG_OPTIMISE_r({
7689         Perl_re_printf( aTHX_ "minlen: %" IVdf " r->minlen:%" IVdf " maxlen:%" IVdf "\n",
7690                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7691     });
7692     r->minlenret = minlen;
7693     if (r->minlen < minlen)
7694         r->minlen = minlen;
7695
7696     if (RExC_seen & REG_RECURSE_SEEN ) {
7697         r->intflags |= PREGf_RECURSE_SEEN;
7698         Newxz(r->recurse_locinput, r->nparens + 1, char *);
7699     }
7700     if (RExC_seen & REG_GPOS_SEEN)
7701         r->intflags |= PREGf_GPOS_SEEN;
7702     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7703         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7704                                                 lookbehind */
7705     if (pRExC_state->num_code_blocks)
7706         r->extflags |= RXf_EVAL_SEEN;
7707     if (RExC_seen & REG_VERBARG_SEEN)
7708     {
7709         r->intflags |= PREGf_VERBARG_SEEN;
7710         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7711     }
7712     if (RExC_seen & REG_CUTGROUP_SEEN)
7713         r->intflags |= PREGf_CUTGROUP_SEEN;
7714     if (pm_flags & PMf_USE_RE_EVAL)
7715         r->intflags |= PREGf_USE_RE_EVAL;
7716     if (RExC_paren_names)
7717         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7718     else
7719         RXp_PAREN_NAMES(r) = NULL;
7720
7721     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7722      * so it can be used in pp.c */
7723     if (r->intflags & PREGf_ANCH)
7724         r->extflags |= RXf_IS_ANCHORED;
7725
7726
7727     {
7728         /* this is used to identify "special" patterns that might result
7729          * in Perl NOT calling the regex engine and instead doing the match "itself",
7730          * particularly special cases in split//. By having the regex compiler
7731          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7732          * we avoid weird issues with equivalent patterns resulting in different behavior,
7733          * AND we allow non Perl engines to get the same optimizations by the setting the
7734          * flags appropriately - Yves */
7735         regnode *first = ri->program + 1;
7736         U8 fop = OP(first);
7737         regnode *next = regnext(first);
7738         U8 nop = OP(next);
7739
7740         if (PL_regkind[fop] == NOTHING && nop == END)
7741             r->extflags |= RXf_NULL;
7742         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7743             /* when fop is SBOL first->flags will be true only when it was
7744              * produced by parsing /\A/, and not when parsing /^/. This is
7745              * very important for the split code as there we want to
7746              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7747              * See rt #122761 for more details. -- Yves */
7748             r->extflags |= RXf_START_ONLY;
7749         else if (fop == PLUS
7750                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7751                  && nop == END)
7752             r->extflags |= RXf_WHITE;
7753         else if ( r->extflags & RXf_SPLIT
7754                   && (fop == EXACT || fop == EXACTL)
7755                   && STR_LEN(first) == 1
7756                   && *(STRING(first)) == ' '
7757                   && nop == END )
7758             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7759
7760     }
7761
7762     if (RExC_contains_locale) {
7763         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7764     }
7765
7766 #ifdef DEBUGGING
7767     if (RExC_paren_names) {
7768         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7769         ri->data->data[ri->name_list_idx]
7770                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7771     } else
7772 #endif
7773     ri->name_list_idx = 0;
7774
7775     while ( RExC_recurse_count > 0 ) {
7776         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7777         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7778     }
7779
7780     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7781     /* assume we don't need to swap parens around before we match */
7782     DEBUG_TEST_r({
7783         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7784             (unsigned long)RExC_study_chunk_recursed_count);
7785     });
7786     DEBUG_DUMP_r({
7787         DEBUG_RExC_seen();
7788         Perl_re_printf( aTHX_ "Final program:\n");
7789         regdump(r);
7790     });
7791 #ifdef RE_TRACK_PATTERN_OFFSETS
7792     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7793         const STRLEN len = ri->u.offsets[0];
7794         STRLEN i;
7795         GET_RE_DEBUG_FLAGS_DECL;
7796         Perl_re_printf( aTHX_
7797                       "Offsets: [%" UVuf "]\n\t", (UV)ri->u.offsets[0]);
7798         for (i = 1; i <= len; i++) {
7799             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7800                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7801                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7802             }
7803         Perl_re_printf( aTHX_  "\n");
7804     });
7805 #endif
7806
7807 #ifdef USE_ITHREADS
7808     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7809      * by setting the regexp SV to readonly-only instead. If the
7810      * pattern's been recompiled, the USEDness should remain. */
7811     if (old_re && SvREADONLY(old_re))
7812         SvREADONLY_on(rx);
7813 #endif
7814     return rx;
7815 }
7816
7817
7818 SV*
7819 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7820                     const U32 flags)
7821 {
7822     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7823
7824     PERL_UNUSED_ARG(value);
7825
7826     if (flags & RXapif_FETCH) {
7827         return reg_named_buff_fetch(rx, key, flags);
7828     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7829         Perl_croak_no_modify();
7830         return NULL;
7831     } else if (flags & RXapif_EXISTS) {
7832         return reg_named_buff_exists(rx, key, flags)
7833             ? &PL_sv_yes
7834             : &PL_sv_no;
7835     } else if (flags & RXapif_REGNAMES) {
7836         return reg_named_buff_all(rx, flags);
7837     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7838         return reg_named_buff_scalar(rx, flags);
7839     } else {
7840         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7841         return NULL;
7842     }
7843 }
7844
7845 SV*
7846 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7847                          const U32 flags)
7848 {
7849     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7850     PERL_UNUSED_ARG(lastkey);
7851
7852     if (flags & RXapif_FIRSTKEY)
7853         return reg_named_buff_firstkey(rx, flags);
7854     else if (flags & RXapif_NEXTKEY)
7855         return reg_named_buff_nextkey(rx, flags);
7856     else {
7857         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7858                                             (int)flags);
7859         return NULL;
7860     }
7861 }
7862
7863 SV*
7864 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7865                           const U32 flags)
7866 {
7867     AV *retarray = NULL;
7868     SV *ret;
7869     struct regexp *const rx = ReANY(r);
7870
7871     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7872
7873     if (flags & RXapif_ALL)
7874         retarray=newAV();
7875
7876     if (rx && RXp_PAREN_NAMES(rx)) {
7877         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7878         if (he_str) {
7879             IV i;
7880             SV* sv_dat=HeVAL(he_str);
7881             I32 *nums=(I32*)SvPVX(sv_dat);
7882             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7883                 if ((I32)(rx->nparens) >= nums[i]
7884                     && rx->offs[nums[i]].start != -1
7885                     && rx->offs[nums[i]].end != -1)
7886                 {
7887                     ret = newSVpvs("");
7888                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7889                     if (!retarray)
7890                         return ret;
7891                 } else {
7892                     if (retarray)
7893                         ret = newSVsv(&PL_sv_undef);
7894                 }
7895                 if (retarray)
7896                     av_push(retarray, ret);
7897             }
7898             if (retarray)
7899                 return newRV_noinc(MUTABLE_SV(retarray));
7900         }
7901     }
7902     return NULL;
7903 }
7904
7905 bool
7906 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7907                            const U32 flags)
7908 {
7909     struct regexp *const rx = ReANY(r);
7910
7911     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7912
7913     if (rx && RXp_PAREN_NAMES(rx)) {
7914         if (flags & RXapif_ALL) {
7915             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7916         } else {
7917             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7918             if (sv) {
7919                 SvREFCNT_dec_NN(sv);
7920                 return TRUE;
7921             } else {
7922                 return FALSE;
7923             }
7924         }
7925     } else {
7926         return FALSE;
7927     }
7928 }
7929
7930 SV*
7931 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7932 {
7933     struct regexp *const rx = ReANY(r);
7934
7935     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7936
7937     if ( rx && RXp_PAREN_NAMES(rx) ) {
7938         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7939
7940         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7941     } else {
7942         return FALSE;
7943     }
7944 }
7945
7946 SV*
7947 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7948 {
7949     struct regexp *const rx = ReANY(r);
7950     GET_RE_DEBUG_FLAGS_DECL;
7951
7952     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7953
7954     if (rx && RXp_PAREN_NAMES(rx)) {
7955         HV *hv = RXp_PAREN_NAMES(rx);
7956         HE *temphe;
7957         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7958             IV i;
7959             IV parno = 0;
7960             SV* sv_dat = HeVAL(temphe);
7961             I32 *nums = (I32*)SvPVX(sv_dat);
7962             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7963                 if ((I32)(rx->lastparen) >= nums[i] &&
7964                     rx->offs[nums[i]].start != -1 &&
7965                     rx->offs[nums[i]].end != -1)
7966                 {
7967                     parno = nums[i];
7968                     break;
7969                 }
7970             }
7971             if (parno || flags & RXapif_ALL) {
7972                 return newSVhek(HeKEY_hek(temphe));
7973             }
7974         }
7975     }
7976     return NULL;
7977 }
7978
7979 SV*
7980 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
7981 {
7982     SV *ret;
7983     AV *av;
7984     SSize_t length;
7985     struct regexp *const rx = ReANY(r);
7986
7987     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
7988
7989     if (rx && RXp_PAREN_NAMES(rx)) {
7990         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
7991             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
7992         } else if (flags & RXapif_ONE) {
7993             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
7994             av = MUTABLE_AV(SvRV(ret));
7995             length = av_tindex(av);
7996             SvREFCNT_dec_NN(ret);
7997             return newSViv(length + 1);
7998         } else {
7999             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8000                                                 (int)flags);
8001             return NULL;
8002         }
8003     }
8004     return &PL_sv_undef;
8005 }
8006
8007 SV*
8008 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8009 {
8010     struct regexp *const rx = ReANY(r);
8011     AV *av = newAV();
8012
8013     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8014
8015     if (rx && RXp_PAREN_NAMES(rx)) {
8016         HV *hv= RXp_PAREN_NAMES(rx);
8017         HE *temphe;
8018         (void)hv_iterinit(hv);
8019         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8020             IV i;
8021             IV parno = 0;
8022             SV* sv_dat = HeVAL(temphe);
8023             I32 *nums = (I32*)SvPVX(sv_dat);
8024             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8025                 if ((I32)(rx->lastparen) >= nums[i] &&
8026                     rx->offs[nums[i]].start != -1 &&
8027                     rx->offs[nums[i]].end != -1)
8028                 {
8029                     parno = nums[i];
8030                     break;
8031                 }
8032             }
8033             if (parno || flags & RXapif_ALL) {
8034                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8035             }
8036         }
8037     }
8038
8039     return newRV_noinc(MUTABLE_SV(av));
8040 }
8041
8042 void
8043 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8044                              SV * const sv)
8045 {
8046     struct regexp *const rx = ReANY(r);
8047     char *s = NULL;
8048     SSize_t i = 0;
8049     SSize_t s1, t1;
8050     I32 n = paren;
8051
8052     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8053
8054     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8055            || n == RX_BUFF_IDX_CARET_FULLMATCH
8056            || n == RX_BUFF_IDX_CARET_POSTMATCH
8057        )
8058     {
8059         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8060         if (!keepcopy) {
8061             /* on something like
8062              *    $r = qr/.../;
8063              *    /$qr/p;
8064              * the KEEPCOPY is set on the PMOP rather than the regex */
8065             if (PL_curpm && r == PM_GETRE(PL_curpm))
8066                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8067         }
8068         if (!keepcopy)
8069             goto ret_undef;
8070     }
8071
8072     if (!rx->subbeg)
8073         goto ret_undef;
8074
8075     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8076         /* no need to distinguish between them any more */
8077         n = RX_BUFF_IDX_FULLMATCH;
8078
8079     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8080         && rx->offs[0].start != -1)
8081     {
8082         /* $`, ${^PREMATCH} */
8083         i = rx->offs[0].start;
8084         s = rx->subbeg;
8085     }
8086     else
8087     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8088         && rx->offs[0].end != -1)
8089     {
8090         /* $', ${^POSTMATCH} */
8091         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8092         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8093     }
8094     else
8095     if ( 0 <= n && n <= (I32)rx->nparens &&
8096         (s1 = rx->offs[n].start) != -1 &&
8097         (t1 = rx->offs[n].end) != -1)
8098     {
8099         /* $&, ${^MATCH},  $1 ... */
8100         i = t1 - s1;
8101         s = rx->subbeg + s1 - rx->suboffset;
8102     } else {
8103         goto ret_undef;
8104     }
8105
8106     assert(s >= rx->subbeg);
8107     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8108     if (i >= 0) {
8109 #ifdef NO_TAINT_SUPPORT
8110         sv_setpvn(sv, s, i);
8111 #else
8112         const int oldtainted = TAINT_get;
8113         TAINT_NOT;
8114         sv_setpvn(sv, s, i);
8115         TAINT_set(oldtainted);
8116 #endif
8117         if (RXp_MATCH_UTF8(rx))
8118             SvUTF8_on(sv);
8119         else
8120             SvUTF8_off(sv);
8121         if (TAINTING_get) {
8122             if (RXp_MATCH_TAINTED(rx)) {
8123                 if (SvTYPE(sv) >= SVt_PVMG) {
8124                     MAGIC* const mg = SvMAGIC(sv);
8125                     MAGIC* mgt;
8126                     TAINT;
8127                     SvMAGIC_set(sv, mg->mg_moremagic);
8128                     SvTAINT(sv);
8129                     if ((mgt = SvMAGIC(sv))) {
8130                         mg->mg_moremagic = mgt;
8131                         SvMAGIC_set(sv, mg);
8132                     }
8133                 } else {
8134                     TAINT;
8135                     SvTAINT(sv);
8136                 }
8137             } else
8138                 SvTAINTED_off(sv);
8139         }
8140     } else {
8141       ret_undef:
8142         sv_set_undef(sv);
8143         return;
8144     }
8145 }
8146
8147 void
8148 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8149                                                          SV const * const value)
8150 {
8151     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8152
8153     PERL_UNUSED_ARG(rx);
8154     PERL_UNUSED_ARG(paren);
8155     PERL_UNUSED_ARG(value);
8156
8157     if (!PL_localizing)
8158         Perl_croak_no_modify();
8159 }
8160
8161 I32
8162 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8163                               const I32 paren)
8164 {
8165     struct regexp *const rx = ReANY(r);
8166     I32 i;
8167     I32 s1, t1;
8168
8169     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8170
8171     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8172         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8173         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8174     )
8175     {
8176         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8177         if (!keepcopy) {
8178             /* on something like
8179              *    $r = qr/.../;
8180              *    /$qr/p;
8181              * the KEEPCOPY is set on the PMOP rather than the regex */
8182             if (PL_curpm && r == PM_GETRE(PL_curpm))
8183                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8184         }
8185         if (!keepcopy)
8186             goto warn_undef;
8187     }
8188
8189     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8190     switch (paren) {
8191       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8192       case RX_BUFF_IDX_PREMATCH:       /* $` */
8193         if (rx->offs[0].start != -1) {
8194                         i = rx->offs[0].start;
8195                         if (i > 0) {
8196                                 s1 = 0;
8197                                 t1 = i;
8198                                 goto getlen;
8199                         }
8200             }
8201         return 0;
8202
8203       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8204       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8205             if (rx->offs[0].end != -1) {
8206                         i = rx->sublen - rx->offs[0].end;
8207                         if (i > 0) {
8208                                 s1 = rx->offs[0].end;
8209                                 t1 = rx->sublen;
8210                                 goto getlen;
8211                         }
8212             }
8213         return 0;
8214
8215       default: /* $& / ${^MATCH}, $1, $2, ... */
8216             if (paren <= (I32)rx->nparens &&
8217             (s1 = rx->offs[paren].start) != -1 &&
8218             (t1 = rx->offs[paren].end) != -1)
8219             {
8220             i = t1 - s1;
8221             goto getlen;
8222         } else {
8223           warn_undef:
8224             if (ckWARN(WARN_UNINITIALIZED))
8225                 report_uninit((const SV *)sv);
8226             return 0;
8227         }
8228     }
8229   getlen:
8230     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8231         const char * const s = rx->subbeg - rx->suboffset + s1;
8232         const U8 *ep;
8233         STRLEN el;
8234
8235         i = t1 - s1;
8236         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8237                         i = el;
8238     }
8239     return i;
8240 }
8241
8242 SV*
8243 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8244 {
8245     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8246         PERL_UNUSED_ARG(rx);
8247         if (0)
8248             return NULL;
8249         else
8250             return newSVpvs("Regexp");
8251 }
8252
8253 /* Scans the name of a named buffer from the pattern.
8254  * If flags is REG_RSN_RETURN_NULL returns null.
8255  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8256  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8257  * to the parsed name as looked up in the RExC_paren_names hash.
8258  * If there is an error throws a vFAIL().. type exception.
8259  */
8260
8261 #define REG_RSN_RETURN_NULL    0
8262 #define REG_RSN_RETURN_NAME    1
8263 #define REG_RSN_RETURN_DATA    2
8264
8265 STATIC SV*
8266 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8267 {
8268     char *name_start = RExC_parse;
8269
8270     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8271
8272     assert (RExC_parse <= RExC_end);
8273     if (RExC_parse == RExC_end) NOOP;
8274     else if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
8275          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8276           * using do...while */
8277         if (UTF)
8278             do {
8279                 RExC_parse += UTF8SKIP(RExC_parse);
8280             } while (isWORDCHAR_utf8((U8*)RExC_parse));
8281         else
8282             do {
8283                 RExC_parse++;
8284             } while (isWORDCHAR(*RExC_parse));
8285     } else {
8286         RExC_parse++; /* so the <- from the vFAIL is after the offending
8287                          character */
8288         vFAIL("Group name must start with a non-digit word character");
8289     }
8290     if ( flags ) {
8291         SV* sv_name
8292             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8293                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8294         if ( flags == REG_RSN_RETURN_NAME)
8295             return sv_name;
8296         else if (flags==REG_RSN_RETURN_DATA) {
8297             HE *he_str = NULL;
8298             SV *sv_dat = NULL;
8299             if ( ! sv_name )      /* should not happen*/
8300                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8301             if (RExC_paren_names)
8302                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8303             if ( he_str )
8304                 sv_dat = HeVAL(he_str);
8305             if ( ! sv_dat )
8306                 vFAIL("Reference to nonexistent named group");
8307             return sv_dat;
8308         }
8309         else {
8310             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8311                        (unsigned long) flags);
8312         }
8313         NOT_REACHED; /* NOTREACHED */
8314     }
8315     return NULL;
8316 }
8317
8318 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8319     int num;                                                    \
8320     if (RExC_lastparse!=RExC_parse) {                           \
8321         Perl_re_printf( aTHX_  "%s",                                        \
8322             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8323                 RExC_end - RExC_parse, 16,                      \
8324                 "", "",                                         \
8325                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8326                 PERL_PV_PRETTY_ELLIPSES   |                     \
8327                 PERL_PV_PRETTY_LTGT       |                     \
8328                 PERL_PV_ESCAPE_RE         |                     \
8329                 PERL_PV_PRETTY_EXACTSIZE                        \
8330             )                                                   \
8331         );                                                      \
8332     } else                                                      \
8333         Perl_re_printf( aTHX_ "%16s","");                                   \
8334                                                                 \
8335     if (SIZE_ONLY)                                              \
8336        num = RExC_size + 1;                                     \
8337     else                                                        \
8338        num=REG_NODE_NUM(RExC_emit);                             \
8339     if (RExC_lastnum!=num)                                      \
8340        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8341     else                                                        \
8342        Perl_re_printf( aTHX_ "|%4s","");                                    \
8343     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8344         (int)((depth*2)), "",                                   \
8345         (funcname)                                              \
8346     );                                                          \
8347     RExC_lastnum=num;                                           \
8348     RExC_lastparse=RExC_parse;                                  \
8349 })
8350
8351
8352
8353 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8354     DEBUG_PARSE_MSG((funcname));                            \
8355     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8356 })
8357 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8358     DEBUG_PARSE_MSG((funcname));                            \
8359     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8360 })
8361
8362 /* This section of code defines the inversion list object and its methods.  The
8363  * interfaces are highly subject to change, so as much as possible is static to
8364  * this file.  An inversion list is here implemented as a malloc'd C UV array
8365  * as an SVt_INVLIST scalar.
8366  *
8367  * An inversion list for Unicode is an array of code points, sorted by ordinal
8368  * number.  Each element gives the code point that begins a range that extends
8369  * up-to but not including the code point given by the next element.  The final
8370  * element gives the first code point of a range that extends to the platform's
8371  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8372  * ...) give ranges whose code points are all in the inversion list.  We say
8373  * that those ranges are in the set.  The odd-numbered elements give ranges
8374  * whose code points are not in the inversion list, and hence not in the set.
8375  * Thus, element [0] is the first code point in the list.  Element [1]
8376  * is the first code point beyond that not in the list; and element [2] is the
8377  * first code point beyond that that is in the list.  In other words, the first
8378  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8379  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8380  * all code points in that range are not in the inversion list.  The third
8381  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8382  * list, and so forth.  Thus every element whose index is divisible by two
8383  * gives the beginning of a range that is in the list, and every element whose
8384  * index is not divisible by two gives the beginning of a range not in the
8385  * list.  If the final element's index is divisible by two, the inversion list
8386  * extends to the platform's infinity; otherwise the highest code point in the
8387  * inversion list is the contents of that element minus 1.
8388  *
8389  * A range that contains just a single code point N will look like
8390  *  invlist[i]   == N
8391  *  invlist[i+1] == N+1
8392  *
8393  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8394  * impossible to represent, so element [i+1] is omitted.  The single element
8395  * inversion list
8396  *  invlist[0] == UV_MAX
8397  * contains just UV_MAX, but is interpreted as matching to infinity.
8398  *
8399  * Taking the complement (inverting) an inversion list is quite simple, if the
8400  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8401  * This implementation reserves an element at the beginning of each inversion
8402  * list to always contain 0; there is an additional flag in the header which
8403  * indicates if the list begins at the 0, or is offset to begin at the next
8404  * element.  This means that the inversion list can be inverted without any
8405  * copying; just flip the flag.
8406  *
8407  * More about inversion lists can be found in "Unicode Demystified"
8408  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8409  *
8410  * The inversion list data structure is currently implemented as an SV pointing
8411  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8412  * array of UV whose memory management is automatically handled by the existing
8413  * facilities for SV's.
8414  *
8415  * Some of the methods should always be private to the implementation, and some
8416  * should eventually be made public */
8417
8418 /* The header definitions are in F<invlist_inline.h> */
8419
8420 #ifndef PERL_IN_XSUB_RE
8421
8422 PERL_STATIC_INLINE UV*
8423 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8424 {
8425     /* Returns a pointer to the first element in the inversion list's array.
8426      * This is called upon initialization of an inversion list.  Where the
8427      * array begins depends on whether the list has the code point U+0000 in it
8428      * or not.  The other parameter tells it whether the code that follows this
8429      * call is about to put a 0 in the inversion list or not.  The first
8430      * element is either the element reserved for 0, if TRUE, or the element
8431      * after it, if FALSE */
8432
8433     bool* offset = get_invlist_offset_addr(invlist);
8434     UV* zero_addr = (UV *) SvPVX(invlist);
8435
8436     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8437
8438     /* Must be empty */
8439     assert(! _invlist_len(invlist));
8440
8441     *zero_addr = 0;
8442
8443     /* 1^1 = 0; 1^0 = 1 */
8444     *offset = 1 ^ will_have_0;
8445     return zero_addr + *offset;
8446 }
8447
8448 #endif
8449
8450 PERL_STATIC_INLINE void
8451 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8452 {
8453     /* Sets the current number of elements stored in the inversion list.
8454      * Updates SvCUR correspondingly */
8455     PERL_UNUSED_CONTEXT;
8456     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8457
8458     assert(SvTYPE(invlist) == SVt_INVLIST);
8459
8460     SvCUR_set(invlist,
8461               (len == 0)
8462                ? 0
8463                : TO_INTERNAL_SIZE(len + offset));
8464     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8465 }
8466
8467 #ifndef PERL_IN_XSUB_RE
8468
8469 STATIC void
8470 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8471 {
8472     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
8473      * steals the list from 'src', so 'src' is made to have a NULL list.  This
8474      * is similar to what SvSetMagicSV() would do, if it were implemented on
8475      * inversion lists, though this routine avoids a copy */
8476
8477     const UV src_len          = _invlist_len(src);
8478     const bool src_offset     = *get_invlist_offset_addr(src);
8479     const STRLEN src_byte_len = SvLEN(src);
8480     char * array              = SvPVX(src);
8481
8482     const int oldtainted = TAINT_get;
8483
8484     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8485
8486     assert(SvTYPE(src) == SVt_INVLIST);
8487     assert(SvTYPE(dest) == SVt_INVLIST);
8488     assert(! invlist_is_iterating(src));
8489     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8490
8491     /* Make sure it ends in the right place with a NUL, as our inversion list
8492      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8493      * asserts it */
8494     array[src_byte_len - 1] = '\0';
8495
8496     TAINT_NOT;      /* Otherwise it breaks */
8497     sv_usepvn_flags(dest,
8498                     (char *) array,
8499                     src_byte_len - 1,
8500
8501                     /* This flag is documented to cause a copy to be avoided */
8502                     SV_HAS_TRAILING_NUL);
8503     TAINT_set(oldtainted);
8504     SvPV_set(src, 0);
8505     SvLEN_set(src, 0);
8506     SvCUR_set(src, 0);
8507
8508     /* Finish up copying over the other fields in an inversion list */
8509     *get_invlist_offset_addr(dest) = src_offset;
8510     invlist_set_len(dest, src_len, src_offset);
8511     *get_invlist_previous_index_addr(dest) = 0;
8512     invlist_iterfinish(dest);
8513 }
8514
8515 PERL_STATIC_INLINE IV*
8516 S_get_invlist_previous_index_addr(SV* invlist)
8517 {
8518     /* Return the address of the IV that is reserved to hold the cached index
8519      * */
8520     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8521
8522     assert(SvTYPE(invlist) == SVt_INVLIST);
8523
8524     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8525 }
8526
8527 PERL_STATIC_INLINE IV
8528 S_invlist_previous_index(SV* const invlist)
8529 {
8530     /* Returns cached index of previous search */
8531
8532     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8533
8534     return *get_invlist_previous_index_addr(invlist);
8535 }
8536
8537 PERL_STATIC_INLINE void
8538 S_invlist_set_previous_index(SV* const invlist, const IV index)
8539 {
8540     /* Caches <index> for later retrieval */
8541
8542     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8543
8544     assert(index == 0 || index < (int) _invlist_len(invlist));
8545
8546     *get_invlist_previous_index_addr(invlist) = index;
8547 }
8548
8549 PERL_STATIC_INLINE void
8550 S_invlist_trim(SV* invlist)
8551 {
8552     /* Free the not currently-being-used space in an inversion list */
8553
8554     /* But don't free up the space needed for the 0 UV that is always at the
8555      * beginning of the list, nor the trailing NUL */
8556     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8557
8558     PERL_ARGS_ASSERT_INVLIST_TRIM;
8559
8560     assert(SvTYPE(invlist) == SVt_INVLIST);
8561
8562     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8563 }
8564
8565 PERL_STATIC_INLINE void
8566 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8567 {
8568     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8569
8570     assert(SvTYPE(invlist) == SVt_INVLIST);
8571
8572     invlist_set_len(invlist, 0, 0);
8573     invlist_trim(invlist);
8574 }
8575
8576 #endif /* ifndef PERL_IN_XSUB_RE */
8577
8578 PERL_STATIC_INLINE bool
8579 S_invlist_is_iterating(SV* const invlist)
8580 {
8581     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8582
8583     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8584 }
8585
8586 #ifndef PERL_IN_XSUB_RE
8587
8588 PERL_STATIC_INLINE UV
8589 S_invlist_max(SV* const invlist)
8590 {
8591     /* Returns the maximum number of elements storable in the inversion list's
8592      * array, without having to realloc() */
8593
8594     PERL_ARGS_ASSERT_INVLIST_MAX;
8595
8596     assert(SvTYPE(invlist) == SVt_INVLIST);
8597
8598     /* Assumes worst case, in which the 0 element is not counted in the
8599      * inversion list, so subtracts 1 for that */
8600     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8601            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8602            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8603 }
8604 SV*
8605 Perl__new_invlist(pTHX_ IV initial_size)
8606 {
8607
8608     /* Return a pointer to a newly constructed inversion list, with enough
8609      * space to store 'initial_size' elements.  If that number is negative, a
8610      * system default is used instead */
8611
8612     SV* new_list;
8613
8614     if (initial_size < 0) {
8615         initial_size = 10;
8616     }
8617
8618     /* Allocate the initial space */
8619     new_list = newSV_type(SVt_INVLIST);
8620
8621     /* First 1 is in case the zero element isn't in the list; second 1 is for
8622      * trailing NUL */
8623     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8624     invlist_set_len(new_list, 0, 0);
8625
8626     /* Force iterinit() to be used to get iteration to work */
8627     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8628
8629     *get_invlist_previous_index_addr(new_list) = 0;
8630
8631     return new_list;
8632 }
8633
8634 SV*
8635 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8636 {
8637     /* Return a pointer to a newly constructed inversion list, initialized to
8638      * point to <list>, which has to be in the exact correct inversion list
8639      * form, including internal fields.  Thus this is a dangerous routine that
8640      * should not be used in the wrong hands.  The passed in 'list' contains
8641      * several header fields at the beginning that are not part of the
8642      * inversion list body proper */
8643
8644     const STRLEN length = (STRLEN) list[0];
8645     const UV version_id =          list[1];
8646     const bool offset   =    cBOOL(list[2]);
8647 #define HEADER_LENGTH 3
8648     /* If any of the above changes in any way, you must change HEADER_LENGTH
8649      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8650      *      perl -E 'say int(rand 2**31-1)'
8651      */
8652 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8653                                         data structure type, so that one being
8654                                         passed in can be validated to be an
8655                                         inversion list of the correct vintage.
8656                                        */
8657
8658     SV* invlist = newSV_type(SVt_INVLIST);
8659
8660     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8661
8662     if (version_id != INVLIST_VERSION_ID) {
8663         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8664     }
8665
8666     /* The generated array passed in includes header elements that aren't part
8667      * of the list proper, so start it just after them */
8668     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8669
8670     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8671                                shouldn't touch it */
8672
8673     *(get_invlist_offset_addr(invlist)) = offset;
8674
8675     /* The 'length' passed to us is the physical number of elements in the
8676      * inversion list.  But if there is an offset the logical number is one
8677      * less than that */
8678     invlist_set_len(invlist, length  - offset, offset);
8679
8680     invlist_set_previous_index(invlist, 0);
8681
8682     /* Initialize the iteration pointer. */
8683     invlist_iterfinish(invlist);
8684
8685     SvREADONLY_on(invlist);
8686
8687     return invlist;
8688 }
8689
8690 STATIC void
8691 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8692 {
8693     /* Grow the maximum size of an inversion list */
8694
8695     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8696
8697     assert(SvTYPE(invlist) == SVt_INVLIST);
8698
8699     /* Add one to account for the zero element at the beginning which may not
8700      * be counted by the calling parameters */
8701     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8702 }
8703
8704 STATIC void
8705 S__append_range_to_invlist(pTHX_ SV* const invlist,
8706                                  const UV start, const UV end)
8707 {
8708    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8709     * the end of the inversion list.  The range must be above any existing
8710     * ones. */
8711
8712     UV* array;
8713     UV max = invlist_max(invlist);
8714     UV len = _invlist_len(invlist);
8715     bool offset;
8716
8717     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8718
8719     if (len == 0) { /* Empty lists must be initialized */
8720         offset = start != 0;
8721         array = _invlist_array_init(invlist, ! offset);
8722     }
8723     else {
8724         /* Here, the existing list is non-empty. The current max entry in the
8725          * list is generally the first value not in the set, except when the
8726          * set extends to the end of permissible values, in which case it is
8727          * the first entry in that final set, and so this call is an attempt to
8728          * append out-of-order */
8729
8730         UV final_element = len - 1;
8731         array = invlist_array(invlist);
8732         if (   array[final_element] > start
8733             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8734         {
8735             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",
8736                      array[final_element], start,
8737                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8738         }
8739
8740         /* Here, it is a legal append.  If the new range begins 1 above the end
8741          * of the range below it, it is extending the range below it, so the
8742          * new first value not in the set is one greater than the newly
8743          * extended range.  */
8744         offset = *get_invlist_offset_addr(invlist);
8745         if (array[final_element] == start) {
8746             if (end != UV_MAX) {
8747                 array[final_element] = end + 1;
8748             }
8749             else {
8750                 /* But if the end is the maximum representable on the machine,
8751                  * assume that infinity was actually what was meant.  Just let
8752                  * the range that this would extend to have no end */
8753                 invlist_set_len(invlist, len - 1, offset);
8754             }
8755             return;
8756         }
8757     }
8758
8759     /* Here the new range doesn't extend any existing set.  Add it */
8760
8761     len += 2;   /* Includes an element each for the start and end of range */
8762
8763     /* If wll overflow the existing space, extend, which may cause the array to
8764      * be moved */
8765     if (max < len) {
8766         invlist_extend(invlist, len);
8767
8768         /* Have to set len here to avoid assert failure in invlist_array() */
8769         invlist_set_len(invlist, len, offset);
8770
8771         array = invlist_array(invlist);
8772     }
8773     else {
8774         invlist_set_len(invlist, len, offset);
8775     }
8776
8777     /* The next item on the list starts the range, the one after that is
8778      * one past the new range.  */
8779     array[len - 2] = start;
8780     if (end != UV_MAX) {
8781         array[len - 1] = end + 1;
8782     }
8783     else {
8784         /* But if the end is the maximum representable on the machine, just let
8785          * the range have no end */
8786         invlist_set_len(invlist, len - 1, offset);
8787     }
8788 }
8789
8790 SSize_t
8791 Perl__invlist_search(SV* const invlist, const UV cp)
8792 {
8793     /* Searches the inversion list for the entry that contains the input code
8794      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8795      * return value is the index into the list's array of the range that
8796      * contains <cp>, that is, 'i' such that
8797      *  array[i] <= cp < array[i+1]
8798      */
8799
8800     IV low = 0;
8801     IV mid;
8802     IV high = _invlist_len(invlist);
8803     const IV highest_element = high - 1;
8804     const UV* array;
8805
8806     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8807
8808     /* If list is empty, return failure. */
8809     if (high == 0) {
8810         return -1;
8811     }
8812
8813     /* (We can't get the array unless we know the list is non-empty) */
8814     array = invlist_array(invlist);
8815
8816     mid = invlist_previous_index(invlist);
8817     assert(mid >=0);
8818     if (mid > highest_element) {
8819         mid = highest_element;
8820     }
8821
8822     /* <mid> contains the cache of the result of the previous call to this
8823      * function (0 the first time).  See if this call is for the same result,
8824      * or if it is for mid-1.  This is under the theory that calls to this
8825      * function will often be for related code points that are near each other.
8826      * And benchmarks show that caching gives better results.  We also test
8827      * here if the code point is within the bounds of the list.  These tests
8828      * replace others that would have had to be made anyway to make sure that
8829      * the array bounds were not exceeded, and these give us extra information
8830      * at the same time */
8831     if (cp >= array[mid]) {
8832         if (cp >= array[highest_element]) {
8833             return highest_element;
8834         }
8835
8836         /* Here, array[mid] <= cp < array[highest_element].  This means that
8837          * the final element is not the answer, so can exclude it; it also
8838          * means that <mid> is not the final element, so can refer to 'mid + 1'
8839          * safely */
8840         if (cp < array[mid + 1]) {
8841             return mid;
8842         }
8843         high--;
8844         low = mid + 1;
8845     }
8846     else { /* cp < aray[mid] */
8847         if (cp < array[0]) { /* Fail if outside the array */
8848             return -1;
8849         }
8850         high = mid;
8851         if (cp >= array[mid - 1]) {
8852             goto found_entry;
8853         }
8854     }
8855
8856     /* Binary search.  What we are looking for is <i> such that
8857      *  array[i] <= cp < array[i+1]
8858      * The loop below converges on the i+1.  Note that there may not be an
8859      * (i+1)th element in the array, and things work nonetheless */
8860     while (low < high) {
8861         mid = (low + high) / 2;
8862         assert(mid <= highest_element);
8863         if (array[mid] <= cp) { /* cp >= array[mid] */
8864             low = mid + 1;
8865
8866             /* We could do this extra test to exit the loop early.
8867             if (cp < array[low]) {
8868                 return mid;
8869             }
8870             */
8871         }
8872         else { /* cp < array[mid] */
8873             high = mid;
8874         }
8875     }
8876
8877   found_entry:
8878     high--;
8879     invlist_set_previous_index(invlist, high);
8880     return high;
8881 }
8882
8883 void
8884 Perl__invlist_populate_swatch(SV* const invlist,
8885                               const UV start, const UV end, U8* swatch)
8886 {
8887     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8888      * but is used when the swash has an inversion list.  This makes this much
8889      * faster, as it uses a binary search instead of a linear one.  This is
8890      * intimately tied to that function, and perhaps should be in utf8.c,
8891      * except it is intimately tied to inversion lists as well.  It assumes
8892      * that <swatch> is all 0's on input */
8893
8894     UV current = start;
8895     const IV len = _invlist_len(invlist);
8896     IV i;
8897     const UV * array;
8898
8899     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8900
8901     if (len == 0) { /* Empty inversion list */
8902         return;
8903     }
8904
8905     array = invlist_array(invlist);
8906
8907     /* Find which element it is */
8908     i = _invlist_search(invlist, start);
8909
8910     /* We populate from <start> to <end> */
8911     while (current < end) {
8912         UV upper;
8913
8914         /* The inversion list gives the results for every possible code point
8915          * after the first one in the list.  Only those ranges whose index is
8916          * even are ones that the inversion list matches.  For the odd ones,
8917          * and if the initial code point is not in the list, we have to skip
8918          * forward to the next element */
8919         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8920             i++;
8921             if (i >= len) { /* Finished if beyond the end of the array */
8922                 return;
8923             }
8924             current = array[i];
8925             if (current >= end) {   /* Finished if beyond the end of what we
8926                                        are populating */
8927                 if (LIKELY(end < UV_MAX)) {
8928                     return;
8929                 }
8930
8931                 /* We get here when the upper bound is the maximum
8932                  * representable on the machine, and we are looking for just
8933                  * that code point.  Have to special case it */
8934                 i = len;
8935                 goto join_end_of_list;
8936             }
8937         }
8938         assert(current >= start);
8939
8940         /* The current range ends one below the next one, except don't go past
8941          * <end> */
8942         i++;
8943         upper = (i < len && array[i] < end) ? array[i] : end;
8944
8945         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8946          * for each code point in it */
8947         for (; current < upper; current++) {
8948             const STRLEN offset = (STRLEN)(current - start);
8949             swatch[offset >> 3] |= 1 << (offset & 7);
8950         }
8951
8952       join_end_of_list:
8953
8954         /* Quit if at the end of the list */
8955         if (i >= len) {
8956
8957             /* But first, have to deal with the highest possible code point on
8958              * the platform.  The previous code assumes that <end> is one
8959              * beyond where we want to populate, but that is impossible at the
8960              * platform's infinity, so have to handle it specially */
8961             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8962             {
8963                 const STRLEN offset = (STRLEN)(end - start);
8964                 swatch[offset >> 3] |= 1 << (offset & 7);
8965             }
8966             return;
8967         }
8968
8969         /* Advance to the next range, which will be for code points not in the
8970          * inversion list */
8971         current = array[i];
8972     }
8973
8974     return;
8975 }
8976
8977 void
8978 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8979                                          const bool complement_b, SV** output)
8980 {
8981     /* Take the union of two inversion lists and point '*output' to it.  On
8982      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
8983      * even 'a' or 'b').  If to an inversion list, the contents of the original
8984      * list will be replaced by the union.  The first list, 'a', may be
8985      * NULL, in which case a copy of the second list is placed in '*output'.
8986      * If 'complement_b' is TRUE, the union is taken of the complement
8987      * (inversion) of 'b' instead of b itself.
8988      *
8989      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8990      * Richard Gillam, published by Addison-Wesley, and explained at some
8991      * length there.  The preface says to incorporate its examples into your
8992      * code at your own risk.
8993      *
8994      * The algorithm is like a merge sort. */
8995
8996     const UV* array_a;    /* a's array */
8997     const UV* array_b;
8998     UV len_a;       /* length of a's array */
8999     UV len_b;
9000
9001     SV* u;                      /* the resulting union */
9002     UV* array_u;
9003     UV len_u = 0;
9004
9005     UV i_a = 0;             /* current index into a's array */
9006     UV i_b = 0;
9007     UV i_u = 0;
9008
9009     /* running count, as explained in the algorithm source book; items are
9010      * stopped accumulating and are output when the count changes to/from 0.
9011      * The count is incremented when we start a range that's in an input's set,
9012      * and decremented when we start a range that's not in a set.  So this
9013      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9014      * and hence nothing goes into the union; 1, just one of the inputs is in
9015      * its set (and its current range gets added to the union); and 2 when both
9016      * inputs are in their sets.  */
9017     UV count = 0;
9018
9019     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9020     assert(a != b);
9021     assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
9022
9023     len_b = _invlist_len(b);
9024     if (len_b == 0) {
9025
9026         /* Here, 'b' is empty, hence it's complement is all possible code
9027          * points.  So if the union includes the complement of 'b', it includes
9028          * everything, and we need not even look at 'a'.  It's easiest to
9029          * create a new inversion list that matches everything.  */
9030         if (complement_b) {
9031             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9032
9033             if (*output == NULL) { /* If the output didn't exist, just point it
9034                                       at the new list */
9035                 *output = everything;
9036             }
9037             else { /* Otherwise, replace its contents with the new list */
9038                 invlist_replace_list_destroys_src(*output, everything);
9039                 SvREFCNT_dec_NN(everything);
9040             }
9041
9042             return;
9043         }
9044
9045         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9046          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9047          * output will be empty */
9048
9049         if (a == NULL || _invlist_len(a) == 0) {
9050             if (*output == NULL) {
9051                 *output = _new_invlist(0);
9052             }
9053             else {
9054                 invlist_clear(*output);
9055             }
9056             return;
9057         }
9058
9059         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9060          * union.  We can just return a copy of 'a' if '*output' doesn't point
9061          * to an existing list */
9062         if (*output == NULL) {
9063             *output = invlist_clone(a);
9064             return;
9065         }
9066
9067         /* If the output is to overwrite 'a', we have a no-op, as it's
9068          * already in 'a' */
9069         if (*output == a) {
9070             return;
9071         }
9072
9073         /* Here, '*output' is to be overwritten by 'a' */
9074         u = invlist_clone(a);
9075         invlist_replace_list_destroys_src(*output, u);
9076         SvREFCNT_dec_NN(u);
9077
9078         return;
9079     }
9080
9081     /* Here 'b' is not empty.  See about 'a' */
9082
9083     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9084
9085         /* Here, 'a' is empty (and b is not).  That means the union will come
9086          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9087          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9088          * the clone */
9089
9090         SV ** dest = (*output == NULL) ? output : &u;
9091         *dest = invlist_clone(b);
9092         if (complement_b) {
9093             _invlist_invert(*dest);
9094         }
9095
9096         if (dest == &u) {
9097             invlist_replace_list_destroys_src(*output, u);
9098             SvREFCNT_dec_NN(u);
9099         }
9100
9101         return;
9102     }
9103
9104     /* Here both lists exist and are non-empty */
9105     array_a = invlist_array(a);
9106     array_b = invlist_array(b);
9107
9108     /* If are to take the union of 'a' with the complement of b, set it
9109      * up so are looking at b's complement. */
9110     if (complement_b) {
9111
9112         /* To complement, we invert: if the first element is 0, remove it.  To
9113          * do this, we just pretend the array starts one later */
9114         if (array_b[0] == 0) {
9115             array_b++;
9116             len_b--;
9117         }
9118         else {
9119
9120             /* But if the first element is not zero, we pretend the list starts
9121              * at the 0 that is always stored immediately before the array. */
9122             array_b--;
9123             len_b++;
9124         }
9125     }
9126
9127     /* Size the union for the worst case: that the sets are completely
9128      * disjoint */
9129     u = _new_invlist(len_a + len_b);
9130
9131     /* Will contain U+0000 if either component does */
9132     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9133                                       || (len_b > 0 && array_b[0] == 0));
9134
9135     /* Go through each input list item by item, stopping when have exhausted
9136      * one of them */
9137     while (i_a < len_a && i_b < len_b) {
9138         UV cp;      /* The element to potentially add to the union's array */
9139         bool cp_in_set;   /* is it in the the input list's set or not */
9140
9141         /* We need to take one or the other of the two inputs for the union.
9142          * Since we are merging two sorted lists, we take the smaller of the
9143          * next items.  In case of a tie, we take first the one that is in its
9144          * set.  If we first took the one not in its set, it would decrement
9145          * the count, possibly to 0 which would cause it to be output as ending
9146          * the range, and the next time through we would take the same number,
9147          * and output it again as beginning the next range.  By doing it the
9148          * opposite way, there is no possibility that the count will be
9149          * momentarily decremented to 0, and thus the two adjoining ranges will
9150          * be seamlessly merged.  (In a tie and both are in the set or both not
9151          * in the set, it doesn't matter which we take first.) */
9152         if (       array_a[i_a] < array_b[i_b]
9153             || (   array_a[i_a] == array_b[i_b]
9154                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9155         {
9156             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9157             cp = array_a[i_a++];
9158         }
9159         else {
9160             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9161             cp = array_b[i_b++];
9162         }
9163
9164         /* Here, have chosen which of the two inputs to look at.  Only output
9165          * if the running count changes to/from 0, which marks the
9166          * beginning/end of a range that's in the set */
9167         if (cp_in_set) {
9168             if (count == 0) {
9169                 array_u[i_u++] = cp;
9170             }
9171             count++;
9172         }
9173         else {
9174             count--;
9175             if (count == 0) {
9176                 array_u[i_u++] = cp;
9177             }
9178         }
9179     }
9180
9181
9182     /* The loop above increments the index into exactly one of the input lists
9183      * each iteration, and ends when either index gets to its list end.  That
9184      * means the other index is lower than its end, and so something is
9185      * remaining in that one.  We decrement 'count', as explained below, if
9186      * that list is in its set.  (i_a and i_b each currently index the element
9187      * beyond the one we care about.) */
9188     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9189         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9190     {
9191         count--;
9192     }
9193
9194     /* Above we decremented 'count' if the list that had unexamined elements in
9195      * it was in its set.  This has made it so that 'count' being non-zero
9196      * means there isn't anything left to output; and 'count' equal to 0 means
9197      * that what is left to output is precisely that which is left in the
9198      * non-exhausted input list.
9199      *
9200      * To see why, note first that the exhausted input obviously has nothing
9201      * left to add to the union.  If it was in its set at its end, that means
9202      * the set extends from here to the platform's infinity, and hence so does
9203      * the union and the non-exhausted set is irrelevant.  The exhausted set
9204      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9205      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9206      * 'count' remains at 1.  This is consistent with the decremented 'count'
9207      * != 0 meaning there's nothing left to add to the union.
9208      *
9209      * But if the exhausted input wasn't in its set, it contributed 0 to
9210      * 'count', and the rest of the union will be whatever the other input is.
9211      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9212      * otherwise it gets decremented to 0.  This is consistent with 'count'
9213      * == 0 meaning the remainder of the union is whatever is left in the
9214      * non-exhausted list. */
9215     if (count != 0) {
9216         len_u = i_u;
9217     }
9218     else {
9219         IV copy_count = len_a - i_a;
9220         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9221             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9222         }
9223         else { /* The non-exhausted input is b */
9224             copy_count = len_b - i_b;
9225             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9226         }
9227         len_u = i_u + copy_count;
9228     }
9229
9230     /* Set the result to the final length, which can change the pointer to
9231      * array_u, so re-find it.  (Note that it is unlikely that this will
9232      * change, as we are shrinking the space, not enlarging it) */
9233     if (len_u != _invlist_len(u)) {
9234         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9235         invlist_trim(u);
9236         array_u = invlist_array(u);
9237     }
9238
9239     if (*output == NULL) {  /* Simply return the new inversion list */
9240         *output = u;
9241     }
9242     else {
9243         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9244          * could instead free '*output', and then set it to 'u', but experience
9245          * has shown [perl #127392] that if the input is a mortal, we can get a
9246          * huge build-up of these during regex compilation before they get
9247          * freed. */
9248         invlist_replace_list_destroys_src(*output, u);
9249         SvREFCNT_dec_NN(u);
9250     }
9251
9252     return;
9253 }
9254
9255 void
9256 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9257                                                const bool complement_b, SV** i)
9258 {
9259     /* Take the intersection of two inversion lists and point '*i' to it.  On
9260      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9261      * even 'a' or 'b').  If to an inversion list, the contents of the original
9262      * list will be replaced by the intersection.  The first list, 'a', may be
9263      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9264      * TRUE, the result will be the intersection of 'a' and the complement (or
9265      * inversion) of 'b' instead of 'b' directly.
9266      *
9267      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9268      * Richard Gillam, published by Addison-Wesley, and explained at some
9269      * length there.  The preface says to incorporate its examples into your
9270      * code at your own risk.  In fact, it had bugs
9271      *
9272      * The algorithm is like a merge sort, and is essentially the same as the
9273      * union above
9274      */
9275
9276     const UV* array_a;          /* a's array */
9277     const UV* array_b;
9278     UV len_a;   /* length of a's array */
9279     UV len_b;
9280
9281     SV* r;                   /* the resulting intersection */
9282     UV* array_r;
9283     UV len_r = 0;
9284
9285     UV i_a = 0;             /* current index into a's array */
9286     UV i_b = 0;
9287     UV i_r = 0;
9288
9289     /* running count of how many of the two inputs are postitioned at ranges
9290      * that are in their sets.  As explained in the algorithm source book,
9291      * items are stopped accumulating and are output when the count changes
9292      * to/from 2.  The count is incremented when we start a range that's in an
9293      * input's set, and decremented when we start a range that's not in a set.
9294      * Only when it is 2 are we in the intersection. */
9295     UV count = 0;
9296
9297     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9298     assert(a != b);
9299     assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
9300
9301     /* Special case if either one is empty */
9302     len_a = (a == NULL) ? 0 : _invlist_len(a);
9303     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9304         if (len_a != 0 && complement_b) {
9305
9306             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9307              * must be empty.  Here, also we are using 'b's complement, which
9308              * hence must be every possible code point.  Thus the intersection
9309              * is simply 'a'. */
9310
9311             if (*i == a) {  /* No-op */
9312                 return;
9313             }
9314
9315             if (*i == NULL) {
9316                 *i = invlist_clone(a);
9317                 return;
9318             }
9319
9320             r = invlist_clone(a);
9321             invlist_replace_list_destroys_src(*i, r);
9322             SvREFCNT_dec_NN(r);
9323             return;
9324         }
9325
9326         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9327          * intersection must be empty */
9328         if (*i == NULL) {
9329             *i = _new_invlist(0);
9330             return;
9331         }
9332
9333         invlist_clear(*i);
9334         return;
9335     }
9336
9337     /* Here both lists exist and are non-empty */
9338     array_a = invlist_array(a);
9339     array_b = invlist_array(b);
9340
9341     /* If are to take the intersection of 'a' with the complement of b, set it
9342      * up so are looking at b's complement. */
9343     if (complement_b) {
9344
9345         /* To complement, we invert: if the first element is 0, remove it.  To
9346          * do this, we just pretend the array starts one later */
9347         if (array_b[0] == 0) {
9348             array_b++;
9349             len_b--;
9350         }
9351         else {
9352
9353             /* But if the first element is not zero, we pretend the list starts
9354              * at the 0 that is always stored immediately before the array. */
9355             array_b--;
9356             len_b++;
9357         }
9358     }
9359
9360     /* Size the intersection for the worst case: that the intersection ends up
9361      * fragmenting everything to be completely disjoint */
9362     r= _new_invlist(len_a + len_b);
9363
9364     /* Will contain U+0000 iff both components do */
9365     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9366                                      && len_b > 0 && array_b[0] == 0);
9367
9368     /* Go through each list item by item, stopping when have exhausted one of
9369      * them */
9370     while (i_a < len_a && i_b < len_b) {
9371         UV cp;      /* The element to potentially add to the intersection's
9372                        array */
9373         bool cp_in_set; /* Is it in the input list's set or not */
9374
9375         /* We need to take one or the other of the two inputs for the
9376          * intersection.  Since we are merging two sorted lists, we take the
9377          * smaller of the next items.  In case of a tie, we take first the one
9378          * that is not in its set (a difference from the union algorithm).  If
9379          * we first took the one in its set, it would increment the count,
9380          * possibly to 2 which would cause it to be output as starting a range
9381          * in the intersection, and the next time through we would take that
9382          * same number, and output it again as ending the set.  By doing the
9383          * opposite of this, there is no possibility that the count will be
9384          * momentarily incremented to 2.  (In a tie and both are in the set or
9385          * both not in the set, it doesn't matter which we take first.) */
9386         if (       array_a[i_a] < array_b[i_b]
9387             || (   array_a[i_a] == array_b[i_b]
9388                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9389         {
9390             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9391             cp = array_a[i_a++];
9392         }
9393         else {
9394             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9395             cp= array_b[i_b++];
9396         }
9397
9398         /* Here, have chosen which of the two inputs to look at.  Only output
9399          * if the running count changes to/from 2, which marks the
9400          * beginning/end of a range that's in the intersection */
9401         if (cp_in_set) {
9402             count++;
9403             if (count == 2) {
9404                 array_r[i_r++] = cp;
9405             }
9406         }
9407         else {
9408             if (count == 2) {
9409                 array_r[i_r++] = cp;
9410             }
9411             count--;
9412         }
9413
9414     }
9415
9416     /* The loop above increments the index into exactly one of the input lists
9417      * each iteration, and ends when either index gets to its list end.  That
9418      * means the other index is lower than its end, and so something is
9419      * remaining in that one.  We increment 'count', as explained below, if the
9420      * exhausted list was in its set.  (i_a and i_b each currently index the
9421      * element beyond the one we care about.) */
9422     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9423         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9424     {
9425         count++;
9426     }
9427
9428     /* Above we incremented 'count' if the exhausted list was in its set.  This
9429      * has made it so that 'count' being below 2 means there is nothing left to
9430      * output; otheriwse what's left to add to the intersection is precisely
9431      * that which is left in the non-exhausted input list.
9432      *
9433      * To see why, note first that the exhausted input obviously has nothing
9434      * left to affect the intersection.  If it was in its set at its end, that
9435      * means the set extends from here to the platform's infinity, and hence
9436      * anything in the non-exhausted's list will be in the intersection, and
9437      * anything not in it won't be.  Hence, the rest of the intersection is
9438      * precisely what's in the non-exhausted list  The exhausted set also
9439      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9440      * it means 'count' is now at least 2.  This is consistent with the
9441      * incremented 'count' being >= 2 means to add the non-exhausted list to
9442      * the intersection.
9443      *
9444      * But if the exhausted input wasn't in its set, it contributed 0 to
9445      * 'count', and the intersection can't include anything further; the
9446      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9447      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9448      * further to add to the intersection. */
9449     if (count < 2) { /* Nothing left to put in the intersection. */
9450         len_r = i_r;
9451     }
9452     else { /* copy the non-exhausted list, unchanged. */
9453         IV copy_count = len_a - i_a;
9454         if (copy_count > 0) {   /* a is the one with stuff left */
9455             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9456         }
9457         else {  /* b is the one with stuff left */
9458             copy_count = len_b - i_b;
9459             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9460         }
9461         len_r = i_r + copy_count;
9462     }
9463
9464     /* Set the result to the final length, which can change the pointer to
9465      * array_r, so re-find it.  (Note that it is unlikely that this will
9466      * change, as we are shrinking the space, not enlarging it) */
9467     if (len_r != _invlist_len(r)) {
9468         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9469         invlist_trim(r);
9470         array_r = invlist_array(r);
9471     }
9472
9473     if (*i == NULL) { /* Simply return the calculated intersection */
9474         *i = r;
9475     }
9476     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9477               instead free '*i', and then set it to 'r', but experience has
9478               shown [perl #127392] that if the input is a mortal, we can get a
9479               huge build-up of these during regex compilation before they get
9480               freed. */
9481         if (len_r) {
9482             invlist_replace_list_destroys_src(*i, r);
9483         }
9484         else {
9485             invlist_clear(*i);
9486         }
9487         SvREFCNT_dec_NN(r);
9488     }
9489
9490     return;
9491 }
9492
9493 SV*
9494 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9495 {
9496     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9497      * set.  A pointer to the inversion list is returned.  This may actually be
9498      * a new list, in which case the passed in one has been destroyed.  The
9499      * passed-in inversion list can be NULL, in which case a new one is created
9500      * with just the one range in it.  The new list is not necessarily
9501      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9502      * result of this function.  The gain would not be large, and in many
9503      * cases, this is called multiple times on a single inversion list, so
9504      * anything freed may almost immediately be needed again.
9505      *
9506      * This used to mostly call the 'union' routine, but that is much more
9507      * heavyweight than really needed for a single range addition */
9508
9509     UV* array;              /* The array implementing the inversion list */
9510     UV len;                 /* How many elements in 'array' */
9511     SSize_t i_s;            /* index into the invlist array where 'start'
9512                                should go */
9513     SSize_t i_e = 0;        /* And the index where 'end' should go */
9514     UV cur_highest;         /* The highest code point in the inversion list
9515                                upon entry to this function */
9516
9517     /* This range becomes the whole inversion list if none already existed */
9518     if (invlist == NULL) {
9519         invlist = _new_invlist(2);
9520         _append_range_to_invlist(invlist, start, end);
9521         return invlist;
9522     }
9523
9524     /* Likewise, if the inversion list is currently empty */
9525     len = _invlist_len(invlist);
9526     if (len == 0) {
9527         _append_range_to_invlist(invlist, start, end);
9528         return invlist;
9529     }
9530
9531     /* Starting here, we have to know the internals of the list */
9532     array = invlist_array(invlist);
9533
9534     /* If the new range ends higher than the current highest ... */
9535     cur_highest = invlist_highest(invlist);
9536     if (end > cur_highest) {
9537
9538         /* If the whole range is higher, we can just append it */
9539         if (start > cur_highest) {
9540             _append_range_to_invlist(invlist, start, end);
9541             return invlist;
9542         }
9543
9544         /* Otherwise, add the portion that is higher ... */
9545         _append_range_to_invlist(invlist, cur_highest + 1, end);
9546
9547         /* ... and continue on below to handle the rest.  As a result of the
9548          * above append, we know that the index of the end of the range is the
9549          * final even numbered one of the array.  Recall that the final element
9550          * always starts a range that extends to infinity.  If that range is in
9551          * the set (meaning the set goes from here to infinity), it will be an
9552          * even index, but if it isn't in the set, it's odd, and the final
9553          * range in the set is one less, which is even. */
9554         if (end == UV_MAX) {
9555             i_e = len;
9556         }
9557         else {
9558             i_e = len - 2;
9559         }
9560     }
9561
9562     /* We have dealt with appending, now see about prepending.  If the new
9563      * range starts lower than the current lowest ... */
9564     if (start < array[0]) {
9565
9566         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
9567          * Let the union code handle it, rather than having to know the
9568          * trickiness in two code places.  */
9569         if (UNLIKELY(start == 0)) {
9570             SV* range_invlist;
9571
9572             range_invlist = _new_invlist(2);
9573             _append_range_to_invlist(range_invlist, start, end);
9574
9575             _invlist_union(invlist, range_invlist, &invlist);
9576
9577             SvREFCNT_dec_NN(range_invlist);
9578
9579             return invlist;
9580         }
9581
9582         /* If the whole new range comes before the first entry, and doesn't
9583          * extend it, we have to insert it as an additional range */
9584         if (end < array[0] - 1) {
9585             i_s = i_e = -1;
9586             goto splice_in_new_range;
9587         }
9588
9589         /* Here the new range adjoins the existing first range, extending it
9590          * downwards. */
9591         array[0] = start;
9592
9593         /* And continue on below to handle the rest.  We know that the index of
9594          * the beginning of the range is the first one of the array */
9595         i_s = 0;
9596     }
9597     else { /* Not prepending any part of the new range to the existing list.
9598             * Find where in the list it should go.  This finds i_s, such that:
9599             *     invlist[i_s] <= start < array[i_s+1]
9600             */
9601         i_s = _invlist_search(invlist, start);
9602     }
9603
9604     /* At this point, any extending before the beginning of the inversion list
9605      * and/or after the end has been done.  This has made it so that, in the
9606      * code below, each endpoint of the new range is either in a range that is
9607      * in the set, or is in a gap between two ranges that are.  This means we
9608      * don't have to worry about exceeding the array bounds.
9609      *
9610      * Find where in the list the new range ends (but we can skip this if we
9611      * have already determined what it is, or if it will be the same as i_s,
9612      * which we already have computed) */
9613     if (i_e == 0) {
9614         i_e = (start == end)
9615               ? i_s
9616               : _invlist_search(invlist, end);
9617     }
9618
9619     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
9620      * is a range that goes to infinity there is no element at invlist[i_e+1],
9621      * so only the first relation holds. */
9622
9623     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9624
9625         /* Here, the ranges on either side of the beginning of the new range
9626          * are in the set, and this range starts in the gap between them.
9627          *
9628          * The new range extends the range above it downwards if the new range
9629          * ends at or above that range's start */
9630         const bool extends_the_range_above = (   end == UV_MAX
9631                                               || end + 1 >= array[i_s+1]);
9632
9633         /* The new range extends the range below it upwards if it begins just
9634          * after where that range ends */
9635         if (start == array[i_s]) {
9636
9637             /* If the new range fills the entire gap between the other ranges,
9638              * they will get merged together.  Other ranges may also get
9639              * merged, depending on how many of them the new range spans.  In
9640              * the general case, we do the merge later, just once, after we
9641              * figure out how many to merge.  But in the case where the new
9642              * range exactly spans just this one gap (possibly extending into
9643              * the one above), we do the merge here, and an early exit.  This
9644              * is done here to avoid having to special case later. */
9645             if (i_e - i_s <= 1) {
9646
9647                 /* If i_e - i_s == 1, it means that the new range terminates
9648                  * within the range above, and hence 'extends_the_range_above'
9649                  * must be true.  (If the range above it extends to infinity,
9650                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
9651                  * will be 0, so no harm done.) */
9652                 if (extends_the_range_above) {
9653                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
9654                     invlist_set_len(invlist,
9655                                     len - 2,
9656                                     *(get_invlist_offset_addr(invlist)));
9657                     return invlist;
9658                 }
9659
9660                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
9661                  * to the same range, and below we are about to decrement i_s
9662                  * */
9663                 i_e--;
9664             }
9665
9666             /* Here, the new range is adjacent to the one below.  (It may also
9667              * span beyond the range above, but that will get resolved later.)
9668              * Extend the range below to include this one. */
9669             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
9670             i_s--;
9671             start = array[i_s];
9672         }
9673         else if (extends_the_range_above) {
9674
9675             /* Here the new range only extends the range above it, but not the
9676              * one below.  It merges with the one above.  Again, we keep i_e
9677              * and i_s in sync if they point to the same range */
9678             if (i_e == i_s) {
9679                 i_e++;
9680             }
9681             i_s++;
9682             array[i_s] = start;
9683         }
9684     }
9685
9686     /* Here, we've dealt with the new range start extending any adjoining
9687      * existing ranges.
9688      *
9689      * If the new range extends to infinity, it is now the final one,
9690      * regardless of what was there before */
9691     if (UNLIKELY(end == UV_MAX)) {
9692         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
9693         return invlist;
9694     }
9695
9696     /* If i_e started as == i_s, it has also been dealt with,
9697      * and been updated to the new i_s, which will fail the following if */
9698     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
9699
9700         /* Here, the ranges on either side of the end of the new range are in
9701          * the set, and this range ends in the gap between them.
9702          *
9703          * If this range is adjacent to (hence extends) the range above it, it
9704          * becomes part of that range; likewise if it extends the range below,
9705          * it becomes part of that range */
9706         if (end + 1 == array[i_e+1]) {
9707             i_e++;
9708             array[i_e] = start;
9709         }
9710         else if (start <= array[i_e]) {
9711             array[i_e] = end + 1;
9712             i_e--;
9713         }
9714     }
9715
9716     if (i_s == i_e) {
9717
9718         /* If the range fits entirely in an existing range (as possibly already
9719          * extended above), it doesn't add anything new */
9720         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9721             return invlist;
9722         }
9723
9724         /* Here, no part of the range is in the list.  Must add it.  It will
9725          * occupy 2 more slots */
9726       splice_in_new_range:
9727
9728         invlist_extend(invlist, len + 2);
9729         array = invlist_array(invlist);
9730         /* Move the rest of the array down two slots. Don't include any
9731          * trailing NUL */
9732         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
9733
9734         /* Do the actual splice */
9735         array[i_e+1] = start;
9736         array[i_e+2] = end + 1;
9737         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
9738         return invlist;
9739     }
9740
9741     /* Here the new range crossed the boundaries of a pre-existing range.  The
9742      * code above has adjusted things so that both ends are in ranges that are
9743      * in the set.  This means everything in between must also be in the set.
9744      * Just squash things together */
9745     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
9746     invlist_set_len(invlist,
9747                     len - i_e + i_s,
9748                     *(get_invlist_offset_addr(invlist)));
9749
9750     return invlist;
9751 }
9752
9753 SV*
9754 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9755                                  UV** other_elements_ptr)
9756 {
9757     /* Create and return an inversion list whose contents are to be populated
9758      * by the caller.  The caller gives the number of elements (in 'size') and
9759      * the very first element ('element0').  This function will set
9760      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9761      * are to be placed.
9762      *
9763      * Obviously there is some trust involved that the caller will properly
9764      * fill in the other elements of the array.
9765      *
9766      * (The first element needs to be passed in, as the underlying code does
9767      * things differently depending on whether it is zero or non-zero) */
9768
9769     SV* invlist = _new_invlist(size);
9770     bool offset;
9771
9772     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9773
9774     invlist = add_cp_to_invlist(invlist, element0);
9775     offset = *get_invlist_offset_addr(invlist);
9776
9777     invlist_set_len(invlist, size, offset);
9778     *other_elements_ptr = invlist_array(invlist) + 1;
9779     return invlist;
9780 }
9781
9782 #endif
9783
9784 PERL_STATIC_INLINE SV*
9785 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9786     return _add_range_to_invlist(invlist, cp, cp);
9787 }
9788
9789 #ifndef PERL_IN_XSUB_RE
9790 void
9791 Perl__invlist_invert(pTHX_ SV* const invlist)
9792 {
9793     /* Complement the input inversion list.  This adds a 0 if the list didn't
9794      * have a zero; removes it otherwise.  As described above, the data
9795      * structure is set up so that this is very efficient */
9796
9797     PERL_ARGS_ASSERT__INVLIST_INVERT;
9798
9799     assert(! invlist_is_iterating(invlist));
9800
9801     /* The inverse of matching nothing is matching everything */
9802     if (_invlist_len(invlist) == 0) {
9803         _append_range_to_invlist(invlist, 0, UV_MAX);
9804         return;
9805     }
9806
9807     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9808 }
9809
9810 #endif
9811
9812 PERL_STATIC_INLINE SV*
9813 S_invlist_clone(pTHX_ SV* const invlist)
9814 {
9815
9816     /* Return a new inversion list that is a copy of the input one, which is
9817      * unchanged.  The new list will not be mortal even if the old one was. */
9818
9819     /* Need to allocate extra space to accommodate Perl's addition of a
9820      * trailing NUL to SvPV's, since it thinks they are always strings */
9821     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9822     STRLEN physical_length = SvCUR(invlist);
9823     bool offset = *(get_invlist_offset_addr(invlist));
9824
9825     PERL_ARGS_ASSERT_INVLIST_CLONE;
9826
9827     *(get_invlist_offset_addr(new_invlist)) = offset;
9828     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9829     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9830
9831     return new_invlist;
9832 }
9833
9834 PERL_STATIC_INLINE STRLEN*
9835 S_get_invlist_iter_addr(SV* invlist)
9836 {
9837     /* Return the address of the UV that contains the current iteration
9838      * position */
9839
9840     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9841
9842     assert(SvTYPE(invlist) == SVt_INVLIST);
9843
9844     return &(((XINVLIST*) SvANY(invlist))->iterator);
9845 }
9846
9847 PERL_STATIC_INLINE void
9848 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9849 {
9850     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9851
9852     *get_invlist_iter_addr(invlist) = 0;
9853 }
9854
9855 PERL_STATIC_INLINE void
9856 S_invlist_iterfinish(SV* invlist)
9857 {
9858     /* Terminate iterator for invlist.  This is to catch development errors.
9859      * Any iteration that is interrupted before completed should call this
9860      * function.  Functions that add code points anywhere else but to the end
9861      * of an inversion list assert that they are not in the middle of an
9862      * iteration.  If they were, the addition would make the iteration
9863      * problematical: if the iteration hadn't reached the place where things
9864      * were being added, it would be ok */
9865
9866     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9867
9868     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9869 }
9870
9871 STATIC bool
9872 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9873 {
9874     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9875      * This call sets in <*start> and <*end>, the next range in <invlist>.
9876      * Returns <TRUE> if successful and the next call will return the next
9877      * range; <FALSE> if was already at the end of the list.  If the latter,
9878      * <*start> and <*end> are unchanged, and the next call to this function
9879      * will start over at the beginning of the list */
9880
9881     STRLEN* pos = get_invlist_iter_addr(invlist);
9882     UV len = _invlist_len(invlist);
9883     UV *array;
9884
9885     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9886
9887     if (*pos >= len) {
9888         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9889         return FALSE;
9890     }
9891
9892     array = invlist_array(invlist);
9893
9894     *start = array[(*pos)++];
9895
9896     if (*pos >= len) {
9897         *end = UV_MAX;
9898     }
9899     else {
9900         *end = array[(*pos)++] - 1;
9901     }
9902
9903     return TRUE;
9904 }
9905
9906 PERL_STATIC_INLINE UV
9907 S_invlist_highest(SV* const invlist)
9908 {
9909     /* Returns the highest code point that matches an inversion list.  This API
9910      * has an ambiguity, as it returns 0 under either the highest is actually
9911      * 0, or if the list is empty.  If this distinction matters to you, check
9912      * for emptiness before calling this function */
9913
9914     UV len = _invlist_len(invlist);
9915     UV *array;
9916
9917     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9918
9919     if (len == 0) {
9920         return 0;
9921     }
9922
9923     array = invlist_array(invlist);
9924
9925     /* The last element in the array in the inversion list always starts a
9926      * range that goes to infinity.  That range may be for code points that are
9927      * matched in the inversion list, or it may be for ones that aren't
9928      * matched.  In the latter case, the highest code point in the set is one
9929      * less than the beginning of this range; otherwise it is the final element
9930      * of this range: infinity */
9931     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9932            ? UV_MAX
9933            : array[len - 1] - 1;
9934 }
9935
9936 STATIC SV *
9937 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
9938 {
9939     /* Get the contents of an inversion list into a string SV so that they can
9940      * be printed out.  If 'traditional_style' is TRUE, it uses the format
9941      * traditionally done for debug tracing; otherwise it uses a format
9942      * suitable for just copying to the output, with blanks between ranges and
9943      * a dash between range components */
9944
9945     UV start, end;
9946     SV* output;
9947     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
9948     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
9949
9950     if (traditional_style) {
9951         output = newSVpvs("\n");
9952     }
9953     else {
9954         output = newSVpvs("");
9955     }
9956
9957     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
9958
9959     assert(! invlist_is_iterating(invlist));
9960
9961     invlist_iterinit(invlist);
9962     while (invlist_iternext(invlist, &start, &end)) {
9963         if (end == UV_MAX) {
9964             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFINITY%c",
9965                                           start, intra_range_delimiter,
9966                                                  inter_range_delimiter);
9967         }
9968         else if (end != start) {
9969             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
9970                                           start,
9971                                                    intra_range_delimiter,
9972                                                   end, inter_range_delimiter);
9973         }
9974         else {
9975             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
9976                                           start, inter_range_delimiter);
9977         }
9978     }
9979
9980     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
9981         SvCUR_set(output, SvCUR(output) - 1);
9982     }
9983
9984     return output;
9985 }
9986
9987 #ifndef PERL_IN_XSUB_RE
9988 void
9989 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
9990                          const char * const indent, SV* const invlist)
9991 {
9992     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
9993      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
9994      * the string 'indent'.  The output looks like this:
9995          [0] 0x000A .. 0x000D
9996          [2] 0x0085
9997          [4] 0x2028 .. 0x2029
9998          [6] 0x3104 .. INFINITY
9999      * This means that the first range of code points matched by the list are
10000      * 0xA through 0xD; the second range contains only the single code point
10001      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10002      * are used to define each range (except if the final range extends to
10003      * infinity, only a single element is needed).  The array index of the
10004      * first element for the corresponding range is given in brackets. */
10005
10006     UV start, end;
10007     STRLEN count = 0;
10008
10009     PERL_ARGS_ASSERT__INVLIST_DUMP;
10010
10011     if (invlist_is_iterating(invlist)) {
10012         Perl_dump_indent(aTHX_ level, file,
10013              "%sCan't dump inversion list because is in middle of iterating\n",
10014              indent);
10015         return;
10016     }
10017
10018     invlist_iterinit(invlist);
10019     while (invlist_iternext(invlist, &start, &end)) {
10020         if (end == UV_MAX) {
10021             Perl_dump_indent(aTHX_ level, file,
10022                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFINITY\n",
10023                                    indent, (UV)count, start);
10024         }
10025         else if (end != start) {
10026             Perl_dump_indent(aTHX_ level, file,
10027                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10028                                 indent, (UV)count, start,         end);
10029         }
10030         else {
10031             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10032                                             indent, (UV)count, start);
10033         }
10034         count += 2;
10035     }
10036 }
10037
10038 void
10039 Perl__load_PL_utf8_foldclosures (pTHX)
10040 {
10041     assert(! PL_utf8_foldclosures);
10042
10043     /* If the folds haven't been read in, call a fold function
10044      * to force that */
10045     if (! PL_utf8_tofold) {
10046         U8 dummy[UTF8_MAXBYTES_CASE+1];
10047
10048         /* This string is just a short named one above \xff */
10049         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
10050         assert(PL_utf8_tofold); /* Verify that worked */
10051     }
10052     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10053 }
10054 #endif
10055
10056 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10057 bool
10058 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10059 {
10060     /* Return a boolean as to if the two passed in inversion lists are
10061      * identical.  The final argument, if TRUE, says to take the complement of
10062      * the second inversion list before doing the comparison */
10063
10064     const UV* array_a = invlist_array(a);
10065     const UV* array_b = invlist_array(b);
10066     UV len_a = _invlist_len(a);
10067     UV len_b = _invlist_len(b);
10068
10069     UV i = 0;               /* current index into the arrays */
10070     bool retval = TRUE;     /* Assume are identical until proven otherwise */
10071
10072     PERL_ARGS_ASSERT__INVLISTEQ;
10073
10074     /* If are to compare 'a' with the complement of b, set it
10075      * up so are looking at b's complement. */
10076     if (complement_b) {
10077
10078         /* The complement of nothing is everything, so <a> would have to have
10079          * just one element, starting at zero (ending at infinity) */
10080         if (len_b == 0) {
10081             return (len_a == 1 && array_a[0] == 0);
10082         }
10083         else if (array_b[0] == 0) {
10084
10085             /* Otherwise, to complement, we invert.  Here, the first element is
10086              * 0, just remove it.  To do this, we just pretend the array starts
10087              * one later */
10088
10089             array_b++;
10090             len_b--;
10091         }
10092         else {
10093
10094             /* But if the first element is not zero, we pretend the list starts
10095              * at the 0 that is always stored immediately before the array. */
10096             array_b--;
10097             len_b++;
10098         }
10099     }
10100
10101     /* Make sure that the lengths are the same, as well as the final element
10102      * before looping through the remainder.  (Thus we test the length, final,
10103      * and first elements right off the bat) */
10104     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
10105         retval = FALSE;
10106     }
10107     else for (i = 0; i < len_a - 1; i++) {
10108         if (array_a[i] != array_b[i]) {
10109             retval = FALSE;
10110             break;
10111         }
10112     }
10113
10114     return retval;
10115 }
10116 #endif
10117
10118 /*
10119  * As best we can, determine the characters that can match the start of
10120  * the given EXACTF-ish node.
10121  *
10122  * Returns the invlist as a new SV*; it is the caller's responsibility to
10123  * call SvREFCNT_dec() when done with it.
10124  */
10125 STATIC SV*
10126 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10127 {
10128     const U8 * s = (U8*)STRING(node);
10129     SSize_t bytelen = STR_LEN(node);
10130     UV uc;
10131     /* Start out big enough for 2 separate code points */
10132     SV* invlist = _new_invlist(4);
10133
10134     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10135
10136     if (! UTF) {
10137         uc = *s;
10138
10139         /* We punt and assume can match anything if the node begins
10140          * with a multi-character fold.  Things are complicated.  For
10141          * example, /ffi/i could match any of:
10142          *  "\N{LATIN SMALL LIGATURE FFI}"
10143          *  "\N{LATIN SMALL LIGATURE FF}I"
10144          *  "F\N{LATIN SMALL LIGATURE FI}"
10145          *  plus several other things; and making sure we have all the
10146          *  possibilities is hard. */
10147         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10148             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10149         }
10150         else {
10151             /* Any Latin1 range character can potentially match any
10152              * other depending on the locale */
10153             if (OP(node) == EXACTFL) {
10154                 _invlist_union(invlist, PL_Latin1, &invlist);
10155             }
10156             else {
10157                 /* But otherwise, it matches at least itself.  We can
10158                  * quickly tell if it has a distinct fold, and if so,
10159                  * it matches that as well */
10160                 invlist = add_cp_to_invlist(invlist, uc);
10161                 if (IS_IN_SOME_FOLD_L1(uc))
10162                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10163             }
10164
10165             /* Some characters match above-Latin1 ones under /i.  This
10166              * is true of EXACTFL ones when the locale is UTF-8 */
10167             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10168                 && (! isASCII(uc) || (OP(node) != EXACTFA
10169                                     && OP(node) != EXACTFA_NO_TRIE)))
10170             {
10171                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10172             }
10173         }
10174     }
10175     else {  /* Pattern is UTF-8 */
10176         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10177         STRLEN foldlen = UTF8SKIP(s);
10178         const U8* e = s + bytelen;
10179         SV** listp;
10180
10181         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10182
10183         /* The only code points that aren't folded in a UTF EXACTFish
10184          * node are are the problematic ones in EXACTFL nodes */
10185         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10186             /* We need to check for the possibility that this EXACTFL
10187              * node begins with a multi-char fold.  Therefore we fold
10188              * the first few characters of it so that we can make that
10189              * check */
10190             U8 *d = folded;
10191             int i;
10192
10193             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10194                 if (isASCII(*s)) {
10195                     *(d++) = (U8) toFOLD(*s);
10196                     s++;
10197                 }
10198                 else {
10199                     STRLEN len;
10200                     to_utf8_fold(s, d, &len);
10201                     d += len;
10202                     s += UTF8SKIP(s);
10203                 }
10204             }
10205
10206             /* And set up so the code below that looks in this folded
10207              * buffer instead of the node's string */
10208             e = d;
10209             foldlen = UTF8SKIP(folded);
10210             s = folded;
10211         }
10212
10213         /* When we reach here 's' points to the fold of the first
10214          * character(s) of the node; and 'e' points to far enough along
10215          * the folded string to be just past any possible multi-char
10216          * fold. 'foldlen' is the length in bytes of the first
10217          * character in 's'
10218          *
10219          * Unlike the non-UTF-8 case, the macro for determining if a
10220          * string is a multi-char fold requires all the characters to
10221          * already be folded.  This is because of all the complications
10222          * if not.  Note that they are folded anyway, except in EXACTFL
10223          * nodes.  Like the non-UTF case above, we punt if the node
10224          * begins with a multi-char fold  */
10225
10226         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10227             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10228         }
10229         else {  /* Single char fold */
10230
10231             /* It matches all the things that fold to it, which are
10232              * found in PL_utf8_foldclosures (including itself) */
10233             invlist = add_cp_to_invlist(invlist, uc);
10234             if (! PL_utf8_foldclosures)
10235                 _load_PL_utf8_foldclosures();
10236             if ((listp = hv_fetch(PL_utf8_foldclosures,
10237                                 (char *) s, foldlen, FALSE)))
10238             {
10239                 AV* list = (AV*) *listp;
10240                 IV k;
10241                 for (k = 0; k <= av_tindex_nomg(list); k++) {
10242                     SV** c_p = av_fetch(list, k, FALSE);
10243                     UV c;
10244                     assert(c_p);
10245
10246                     c = SvUV(*c_p);
10247
10248                     /* /aa doesn't allow folds between ASCII and non- */
10249                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
10250                         && isASCII(c) != isASCII(uc))
10251                     {
10252                         continue;
10253                     }
10254
10255                     invlist = add_cp_to_invlist(invlist, c);
10256                 }
10257             }
10258         }
10259     }
10260
10261     return invlist;
10262 }
10263
10264 #undef HEADER_LENGTH
10265 #undef TO_INTERNAL_SIZE
10266 #undef FROM_INTERNAL_SIZE
10267 #undef INVLIST_VERSION_ID
10268
10269 /* End of inversion list object */
10270
10271 STATIC void
10272 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10273 {
10274     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10275      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10276      * should point to the first flag; it is updated on output to point to the
10277      * final ')' or ':'.  There needs to be at least one flag, or this will
10278      * abort */
10279
10280     /* for (?g), (?gc), and (?o) warnings; warning
10281        about (?c) will warn about (?g) -- japhy    */
10282
10283 #define WASTED_O  0x01
10284 #define WASTED_G  0x02
10285 #define WASTED_C  0x04
10286 #define WASTED_GC (WASTED_G|WASTED_C)
10287     I32 wastedflags = 0x00;
10288     U32 posflags = 0, negflags = 0;
10289     U32 *flagsp = &posflags;
10290     char has_charset_modifier = '\0';
10291     regex_charset cs;
10292     bool has_use_defaults = FALSE;
10293     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10294     int x_mod_count = 0;
10295
10296     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10297
10298     /* '^' as an initial flag sets certain defaults */
10299     if (UCHARAT(RExC_parse) == '^') {
10300         RExC_parse++;
10301         has_use_defaults = TRUE;
10302         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10303         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10304                                         ? REGEX_UNICODE_CHARSET
10305                                         : REGEX_DEPENDS_CHARSET);
10306     }
10307
10308     cs = get_regex_charset(RExC_flags);
10309     if (cs == REGEX_DEPENDS_CHARSET
10310         && (RExC_utf8 || RExC_uni_semantics))
10311     {
10312         cs = REGEX_UNICODE_CHARSET;
10313     }
10314
10315     while (RExC_parse < RExC_end) {
10316         /* && strchr("iogcmsx", *RExC_parse) */
10317         /* (?g), (?gc) and (?o) are useless here
10318            and must be globally applied -- japhy */
10319         switch (*RExC_parse) {
10320
10321             /* Code for the imsxn flags */
10322             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10323
10324             case LOCALE_PAT_MOD:
10325                 if (has_charset_modifier) {
10326                     goto excess_modifier;
10327                 }
10328                 else if (flagsp == &negflags) {
10329                     goto neg_modifier;
10330                 }
10331                 cs = REGEX_LOCALE_CHARSET;
10332                 has_charset_modifier = LOCALE_PAT_MOD;
10333                 break;
10334             case UNICODE_PAT_MOD:
10335                 if (has_charset_modifier) {
10336                     goto excess_modifier;
10337                 }
10338                 else if (flagsp == &negflags) {
10339                     goto neg_modifier;
10340                 }
10341                 cs = REGEX_UNICODE_CHARSET;
10342                 has_charset_modifier = UNICODE_PAT_MOD;
10343                 break;
10344             case ASCII_RESTRICT_PAT_MOD:
10345                 if (flagsp == &negflags) {
10346                     goto neg_modifier;
10347                 }
10348                 if (has_charset_modifier) {
10349                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10350                         goto excess_modifier;
10351                     }
10352                     /* Doubled modifier implies more restricted */
10353                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10354                 }
10355                 else {
10356                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10357                 }
10358                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10359                 break;
10360             case DEPENDS_PAT_MOD:
10361                 if (has_use_defaults) {
10362                     goto fail_modifiers;
10363                 }
10364                 else if (flagsp == &negflags) {
10365                     goto neg_modifier;
10366                 }
10367                 else if (has_charset_modifier) {
10368                     goto excess_modifier;
10369                 }
10370
10371                 /* The dual charset means unicode semantics if the
10372                  * pattern (or target, not known until runtime) are
10373                  * utf8, or something in the pattern indicates unicode
10374                  * semantics */
10375                 cs = (RExC_utf8 || RExC_uni_semantics)
10376                      ? REGEX_UNICODE_CHARSET
10377                      : REGEX_DEPENDS_CHARSET;
10378                 has_charset_modifier = DEPENDS_PAT_MOD;
10379                 break;
10380               excess_modifier:
10381                 RExC_parse++;
10382                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10383                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10384                 }
10385                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10386                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10387                                         *(RExC_parse - 1));
10388                 }
10389                 else {
10390                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10391                 }
10392                 NOT_REACHED; /*NOTREACHED*/
10393               neg_modifier:
10394                 RExC_parse++;
10395                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10396                                     *(RExC_parse - 1));
10397                 NOT_REACHED; /*NOTREACHED*/
10398             case ONCE_PAT_MOD: /* 'o' */
10399             case GLOBAL_PAT_MOD: /* 'g' */
10400                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10401                     const I32 wflagbit = *RExC_parse == 'o'
10402                                          ? WASTED_O
10403                                          : WASTED_G;
10404                     if (! (wastedflags & wflagbit) ) {
10405                         wastedflags |= wflagbit;
10406                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10407                         vWARN5(
10408                             RExC_parse + 1,
10409                             "Useless (%s%c) - %suse /%c modifier",
10410                             flagsp == &negflags ? "?-" : "?",
10411                             *RExC_parse,
10412                             flagsp == &negflags ? "don't " : "",
10413                             *RExC_parse
10414                         );
10415                     }
10416                 }
10417                 break;
10418
10419             case CONTINUE_PAT_MOD: /* 'c' */
10420                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10421                     if (! (wastedflags & WASTED_C) ) {
10422                         wastedflags |= WASTED_GC;
10423                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10424                         vWARN3(
10425                             RExC_parse + 1,
10426                             "Useless (%sc) - %suse /gc modifier",
10427                             flagsp == &negflags ? "?-" : "?",
10428                             flagsp == &negflags ? "don't " : ""
10429                         );
10430                     }
10431                 }
10432                 break;
10433             case KEEPCOPY_PAT_MOD: /* 'p' */
10434                 if (flagsp == &negflags) {
10435                     if (PASS2)
10436                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10437                 } else {
10438                     *flagsp |= RXf_PMf_KEEPCOPY;
10439                 }
10440                 break;
10441             case '-':
10442                 /* A flag is a default iff it is following a minus, so
10443                  * if there is a minus, it means will be trying to
10444                  * re-specify a default which is an error */
10445                 if (has_use_defaults || flagsp == &negflags) {
10446                     goto fail_modifiers;
10447                 }
10448                 flagsp = &negflags;
10449                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10450                 break;
10451             case ':':
10452             case ')':
10453                 RExC_flags |= posflags;
10454                 RExC_flags &= ~negflags;
10455                 set_regex_charset(&RExC_flags, cs);
10456                 if (RExC_flags & RXf_PMf_FOLD) {
10457                     RExC_contains_i = 1;
10458                 }
10459
10460                 if (UNLIKELY((x_mod_count) > 1)) {
10461                     vFAIL("Only one /x regex modifier is allowed");
10462                 }
10463                 return;
10464                 /*NOTREACHED*/
10465             default:
10466               fail_modifiers:
10467                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10468                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10469                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10470                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10471                 NOT_REACHED; /*NOTREACHED*/
10472         }
10473
10474         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10475     }
10476
10477     vFAIL("Sequence (?... not terminated");
10478 }
10479
10480 /*
10481  - reg - regular expression, i.e. main body or parenthesized thing
10482  *
10483  * Caller must absorb opening parenthesis.
10484  *
10485  * Combining parenthesis handling with the base level of regular expression
10486  * is a trifle forced, but the need to tie the tails of the branches to what
10487  * follows makes it hard to avoid.
10488  */
10489 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10490 #ifdef DEBUGGING
10491 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10492 #else
10493 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10494 #endif
10495
10496 PERL_STATIC_INLINE regnode *
10497 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10498                              I32 *flagp,
10499                              char * parse_start,
10500                              char ch
10501                       )
10502 {
10503     regnode *ret;
10504     char* name_start = RExC_parse;
10505     U32 num = 0;
10506     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10507                                             ? REG_RSN_RETURN_NULL
10508                                             : REG_RSN_RETURN_DATA);
10509     GET_RE_DEBUG_FLAGS_DECL;
10510
10511     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10512
10513     if (RExC_parse == name_start || *RExC_parse != ch) {
10514         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10515         vFAIL2("Sequence %.3s... not terminated",parse_start);
10516     }
10517
10518     if (!SIZE_ONLY) {
10519         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10520         RExC_rxi->data->data[num]=(void*)sv_dat;
10521         SvREFCNT_inc_simple_void(sv_dat);
10522     }
10523     RExC_sawback = 1;
10524     ret = reganode(pRExC_state,
10525                    ((! FOLD)
10526                      ? NREF
10527                      : (ASCII_FOLD_RESTRICTED)
10528                        ? NREFFA
10529                        : (AT_LEAST_UNI_SEMANTICS)
10530                          ? NREFFU
10531                          : (LOC)
10532                            ? NREFFL
10533                            : NREFF),
10534                     num);
10535     *flagp |= HASWIDTH;
10536
10537     Set_Node_Offset(ret, parse_start+1);
10538     Set_Node_Cur_Length(ret, parse_start);
10539
10540     nextchar(pRExC_state);
10541     return ret;
10542 }
10543
10544 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10545    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10546    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10547    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10548    NULL, which cannot happen.  */
10549 STATIC regnode *
10550 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10551     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10552      * 2 is like 1, but indicates that nextchar() has been called to advance
10553      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10554      * this flag alerts us to the need to check for that */
10555 {
10556     regnode *ret;               /* Will be the head of the group. */
10557     regnode *br;
10558     regnode *lastbr;
10559     regnode *ender = NULL;
10560     I32 parno = 0;
10561     I32 flags;
10562     U32 oregflags = RExC_flags;
10563     bool have_branch = 0;
10564     bool is_open = 0;
10565     I32 freeze_paren = 0;
10566     I32 after_freeze = 0;
10567     I32 num; /* numeric backreferences */
10568
10569     char * parse_start = RExC_parse; /* MJD */
10570     char * const oregcomp_parse = RExC_parse;
10571
10572     GET_RE_DEBUG_FLAGS_DECL;
10573
10574     PERL_ARGS_ASSERT_REG;
10575     DEBUG_PARSE("reg ");
10576
10577     *flagp = 0;                         /* Tentatively. */
10578
10579     /* Having this true makes it feasible to have a lot fewer tests for the
10580      * parse pointer being in scope.  For example, we can write
10581      *      while(isFOO(*RExC_parse)) RExC_parse++;
10582      * instead of
10583      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10584      */
10585     assert(*RExC_end == '\0');
10586
10587     /* Make an OPEN node, if parenthesized. */
10588     if (paren) {
10589
10590         /* Under /x, space and comments can be gobbled up between the '(' and
10591          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10592          * intervening space, as the sequence is a token, and a token should be
10593          * indivisible */
10594         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
10595
10596         if (RExC_parse >= RExC_end) {
10597             vFAIL("Unmatched (");
10598         }
10599
10600         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
10601             char *start_verb = RExC_parse + 1;
10602             STRLEN verb_len;
10603             char *start_arg = NULL;
10604             unsigned char op = 0;
10605             int arg_required = 0;
10606             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10607
10608             if (has_intervening_patws) {
10609                 RExC_parse++;   /* past the '*' */
10610                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10611             }
10612             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10613                 if ( *RExC_parse == ':' ) {
10614                     start_arg = RExC_parse + 1;
10615                     break;
10616                 }
10617                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10618             }
10619             verb_len = RExC_parse - start_verb;
10620             if ( start_arg ) {
10621                 if (RExC_parse >= RExC_end) {
10622                     goto unterminated_verb_pattern;
10623                 }
10624                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10625                 while ( RExC_parse < RExC_end && *RExC_parse != ')' )
10626                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10627                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10628                   unterminated_verb_pattern:
10629                     vFAIL("Unterminated verb pattern argument");
10630                 if ( RExC_parse == start_arg )
10631                     start_arg = NULL;
10632             } else {
10633                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10634                     vFAIL("Unterminated verb pattern");
10635             }
10636
10637             /* Here, we know that RExC_parse < RExC_end */
10638
10639             switch ( *start_verb ) {
10640             case 'A':  /* (*ACCEPT) */
10641                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10642                     op = ACCEPT;
10643                     internal_argval = RExC_nestroot;
10644                 }
10645                 break;
10646             case 'C':  /* (*COMMIT) */
10647                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10648                     op = COMMIT;
10649                 break;
10650             case 'F':  /* (*FAIL) */
10651                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10652                     op = OPFAIL;
10653                 }
10654                 break;
10655             case ':':  /* (*:NAME) */
10656             case 'M':  /* (*MARK:NAME) */
10657                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10658                     op = MARKPOINT;
10659                     arg_required = 1;
10660                 }
10661                 break;
10662             case 'P':  /* (*PRUNE) */
10663                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10664                     op = PRUNE;
10665                 break;
10666             case 'S':   /* (*SKIP) */
10667                 if ( memEQs(start_verb,verb_len,"SKIP") )
10668                     op = SKIP;
10669                 break;
10670             case 'T':  /* (*THEN) */
10671                 /* [19:06] <TimToady> :: is then */
10672                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10673                     op = CUTGROUP;
10674                     RExC_seen |= REG_CUTGROUP_SEEN;
10675                 }
10676                 break;
10677             }
10678             if ( ! op ) {
10679                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10680                 vFAIL2utf8f(
10681                     "Unknown verb pattern '%" UTF8f "'",
10682                     UTF8fARG(UTF, verb_len, start_verb));
10683             }
10684             if ( arg_required && !start_arg ) {
10685                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
10686                     verb_len, start_verb);
10687             }
10688             if (internal_argval == -1) {
10689                 ret = reganode(pRExC_state, op, 0);
10690             } else {
10691                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
10692             }
10693             RExC_seen |= REG_VERBARG_SEEN;
10694             if ( ! SIZE_ONLY ) {
10695                 if (start_arg) {
10696                     SV *sv = newSVpvn( start_arg,
10697                                        RExC_parse - start_arg);
10698                     ARG(ret) = add_data( pRExC_state,
10699                                          STR_WITH_LEN("S"));
10700                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
10701                     ret->flags = 1;
10702                 } else {
10703                     ret->flags = 0;
10704                 }
10705                 if ( internal_argval != -1 )
10706                     ARG2L_SET(ret, internal_argval);
10707             }
10708             nextchar(pRExC_state);
10709             return ret;
10710         }
10711         else if (*RExC_parse == '?') { /* (?...) */
10712             bool is_logical = 0;
10713             const char * const seqstart = RExC_parse;
10714             const char * endptr;
10715             if (has_intervening_patws) {
10716                 RExC_parse++;
10717                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
10718             }
10719
10720             RExC_parse++;           /* past the '?' */
10721             paren = *RExC_parse;    /* might be a trailing NUL, if not
10722                                        well-formed */
10723             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10724             if (RExC_parse > RExC_end) {
10725                 paren = '\0';
10726             }
10727             ret = NULL;                 /* For look-ahead/behind. */
10728             switch (paren) {
10729
10730             case 'P':   /* (?P...) variants for those used to PCRE/Python */
10731                 paren = *RExC_parse;
10732                 if ( paren == '<') {    /* (?P<...>) named capture */
10733                     RExC_parse++;
10734                     if (RExC_parse >= RExC_end) {
10735                         vFAIL("Sequence (?P<... not terminated");
10736                     }
10737                     goto named_capture;
10738                 }
10739                 else if (paren == '>') {   /* (?P>name) named recursion */
10740                     RExC_parse++;
10741                     if (RExC_parse >= RExC_end) {
10742                         vFAIL("Sequence (?P>... not terminated");
10743                     }
10744                     goto named_recursion;
10745                 }
10746                 else if (paren == '=') {   /* (?P=...)  named backref */
10747                     RExC_parse++;
10748                     return handle_named_backref(pRExC_state, flagp,
10749                                                 parse_start, ')');
10750                 }
10751                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10752                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10753                 vFAIL3("Sequence (%.*s...) not recognized",
10754                                 RExC_parse-seqstart, seqstart);
10755                 NOT_REACHED; /*NOTREACHED*/
10756             case '<':           /* (?<...) */
10757                 if (*RExC_parse == '!')
10758                     paren = ',';
10759                 else if (*RExC_parse != '=')
10760               named_capture:
10761                 {               /* (?<...>) */
10762                     char *name_start;
10763                     SV *svname;
10764                     paren= '>';
10765                 /* FALLTHROUGH */
10766             case '\'':          /* (?'...') */
10767                     name_start = RExC_parse;
10768                     svname = reg_scan_name(pRExC_state,
10769                         SIZE_ONLY    /* reverse test from the others */
10770                         ? REG_RSN_RETURN_NAME
10771                         : REG_RSN_RETURN_NULL);
10772                     if (   RExC_parse == name_start
10773                         || RExC_parse >= RExC_end
10774                         || *RExC_parse != paren)
10775                     {
10776                         vFAIL2("Sequence (?%c... not terminated",
10777                             paren=='>' ? '<' : paren);
10778                     }
10779                     if (SIZE_ONLY) {
10780                         HE *he_str;
10781                         SV *sv_dat = NULL;
10782                         if (!svname) /* shouldn't happen */
10783                             Perl_croak(aTHX_
10784                                 "panic: reg_scan_name returned NULL");
10785                         if (!RExC_paren_names) {
10786                             RExC_paren_names= newHV();
10787                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10788 #ifdef DEBUGGING
10789                             RExC_paren_name_list= newAV();
10790                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10791 #endif
10792                         }
10793                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10794                         if ( he_str )
10795                             sv_dat = HeVAL(he_str);
10796                         if ( ! sv_dat ) {
10797                             /* croak baby croak */
10798                             Perl_croak(aTHX_
10799                                 "panic: paren_name hash element allocation failed");
10800                         } else if ( SvPOK(sv_dat) ) {
10801                             /* (?|...) can mean we have dupes so scan to check
10802                                its already been stored. Maybe a flag indicating
10803                                we are inside such a construct would be useful,
10804                                but the arrays are likely to be quite small, so
10805                                for now we punt -- dmq */
10806                             IV count = SvIV(sv_dat);
10807                             I32 *pv = (I32*)SvPVX(sv_dat);
10808                             IV i;
10809                             for ( i = 0 ; i < count ; i++ ) {
10810                                 if ( pv[i] == RExC_npar ) {
10811                                     count = 0;
10812                                     break;
10813                                 }
10814                             }
10815                             if ( count ) {
10816                                 pv = (I32*)SvGROW(sv_dat,
10817                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10818                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10819                                 pv[count] = RExC_npar;
10820                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10821                             }
10822                         } else {
10823                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10824                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10825                                                                 sizeof(I32));
10826                             SvIOK_on(sv_dat);
10827                             SvIV_set(sv_dat, 1);
10828                         }
10829 #ifdef DEBUGGING
10830                         /* Yes this does cause a memory leak in debugging Perls
10831                          * */
10832                         if (!av_store(RExC_paren_name_list,
10833                                       RExC_npar, SvREFCNT_inc(svname)))
10834                             SvREFCNT_dec_NN(svname);
10835 #endif
10836
10837                         /*sv_dump(sv_dat);*/
10838                     }
10839                     nextchar(pRExC_state);
10840                     paren = 1;
10841                     goto capturing_parens;
10842                 }
10843                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10844                 RExC_in_lookbehind++;
10845                 RExC_parse++;
10846                 if (RExC_parse >= RExC_end) {
10847                     vFAIL("Sequence (?... not terminated");
10848                 }
10849
10850                 /* FALLTHROUGH */
10851             case '=':           /* (?=...) */
10852                 RExC_seen_zerolen++;
10853                 break;
10854             case '!':           /* (?!...) */
10855                 RExC_seen_zerolen++;
10856                 /* check if we're really just a "FAIL" assertion */
10857                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
10858                                         FALSE /* Don't force to /x */ );
10859                 if (*RExC_parse == ')') {
10860                     ret=reganode(pRExC_state, OPFAIL, 0);
10861                     nextchar(pRExC_state);
10862                     return ret;
10863                 }
10864                 break;
10865             case '|':           /* (?|...) */
10866                 /* branch reset, behave like a (?:...) except that
10867                    buffers in alternations share the same numbers */
10868                 paren = ':';
10869                 after_freeze = freeze_paren = RExC_npar;
10870                 break;
10871             case ':':           /* (?:...) */
10872             case '>':           /* (?>...) */
10873                 break;
10874             case '$':           /* (?$...) */
10875             case '@':           /* (?@...) */
10876                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10877                 break;
10878             case '0' :           /* (?0) */
10879             case 'R' :           /* (?R) */
10880                 if (RExC_parse == RExC_end || *RExC_parse != ')')
10881                     FAIL("Sequence (?R) not terminated");
10882                 num = 0;
10883                 RExC_seen |= REG_RECURSE_SEEN;
10884                 *flagp |= POSTPONED;
10885                 goto gen_recurse_regop;
10886                 /*notreached*/
10887             /* named and numeric backreferences */
10888             case '&':            /* (?&NAME) */
10889                 parse_start = RExC_parse - 1;
10890               named_recursion:
10891                 {
10892                     SV *sv_dat = reg_scan_name(pRExC_state,
10893                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10894                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10895                 }
10896                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
10897                     vFAIL("Sequence (?&... not terminated");
10898                 goto gen_recurse_regop;
10899                 /* NOTREACHED */
10900             case '+':
10901                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10902                     RExC_parse++;
10903                     vFAIL("Illegal pattern");
10904                 }
10905                 goto parse_recursion;
10906                 /* NOTREACHED*/
10907             case '-': /* (?-1) */
10908                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10909                     RExC_parse--; /* rewind to let it be handled later */
10910                     goto parse_flags;
10911                 }
10912                 /* FALLTHROUGH */
10913             case '1': case '2': case '3': case '4': /* (?1) */
10914             case '5': case '6': case '7': case '8': case '9':
10915                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
10916               parse_recursion:
10917                 {
10918                     bool is_neg = FALSE;
10919                     UV unum;
10920                     parse_start = RExC_parse - 1; /* MJD */
10921                     if (*RExC_parse == '-') {
10922                         RExC_parse++;
10923                         is_neg = TRUE;
10924                     }
10925                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10926                         && unum <= I32_MAX
10927                     ) {
10928                         num = (I32)unum;
10929                         RExC_parse = (char*)endptr;
10930                     } else
10931                         num = I32_MAX;
10932                     if (is_neg) {
10933                         /* Some limit for num? */
10934                         num = -num;
10935                     }
10936                 }
10937                 if (*RExC_parse!=')')
10938                     vFAIL("Expecting close bracket");
10939
10940               gen_recurse_regop:
10941                 if ( paren == '-' ) {
10942                     /*
10943                     Diagram of capture buffer numbering.
10944                     Top line is the normal capture buffer numbers
10945                     Bottom line is the negative indexing as from
10946                     the X (the (?-2))
10947
10948                     +   1 2    3 4 5 X          6 7
10949                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
10950                     -   5 4    3 2 1 X          x x
10951
10952                     */
10953                     num = RExC_npar + num;
10954                     if (num < 1)  {
10955                         RExC_parse++;
10956                         vFAIL("Reference to nonexistent group");
10957                     }
10958                 } else if ( paren == '+' ) {
10959                     num = RExC_npar + num - 1;
10960                 }
10961                 /* We keep track how many GOSUB items we have produced.
10962                    To start off the ARG2L() of the GOSUB holds its "id",
10963                    which is used later in conjunction with RExC_recurse
10964                    to calculate the offset we need to jump for the GOSUB,
10965                    which it will store in the final representation.
10966                    We have to defer the actual calculation until much later
10967                    as the regop may move.
10968                  */
10969
10970                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
10971                 if (!SIZE_ONLY) {
10972                     if (num > (I32)RExC_rx->nparens) {
10973                         RExC_parse++;
10974                         vFAIL("Reference to nonexistent group");
10975                     }
10976                     RExC_recurse_count++;
10977                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
10978                         "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
10979                               22, "|    |", (int)(depth * 2 + 1), "",
10980                               (UV)ARG(ret), (IV)ARG2L(ret)));
10981                 }
10982                 RExC_seen |= REG_RECURSE_SEEN;
10983
10984                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
10985                 Set_Node_Offset(ret, parse_start); /* MJD */
10986
10987                 *flagp |= POSTPONED;
10988                 assert(*RExC_parse == ')');
10989                 nextchar(pRExC_state);
10990                 return ret;
10991
10992             /* NOTREACHED */
10993
10994             case '?':           /* (??...) */
10995                 is_logical = 1;
10996                 if (*RExC_parse != '{') {
10997                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
10998                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10999                     vFAIL2utf8f(
11000                         "Sequence (%" UTF8f "...) not recognized",
11001                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11002                     NOT_REACHED; /*NOTREACHED*/
11003                 }
11004                 *flagp |= POSTPONED;
11005                 paren = '{';
11006                 RExC_parse++;
11007                 /* FALLTHROUGH */
11008             case '{':           /* (?{...}) */
11009             {
11010                 U32 n = 0;
11011                 struct reg_code_block *cb;
11012
11013                 RExC_seen_zerolen++;
11014
11015                 if (   !pRExC_state->num_code_blocks
11016                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
11017                     || pRExC_state->code_blocks[pRExC_state->code_index].start
11018                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11019                             - RExC_start)
11020                 ) {
11021                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11022                         FAIL("panic: Sequence (?{...}): no code block found\n");
11023                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11024                 }
11025                 /* this is a pre-compiled code block (?{...}) */
11026                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
11027                 RExC_parse = RExC_start + cb->end;
11028                 if (!SIZE_ONLY) {
11029                     OP *o = cb->block;
11030                     if (cb->src_regex) {
11031                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11032                         RExC_rxi->data->data[n] =
11033                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
11034                         RExC_rxi->data->data[n+1] = (void*)o;
11035                     }
11036                     else {
11037                         n = add_data(pRExC_state,
11038                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11039                         RExC_rxi->data->data[n] = (void*)o;
11040                     }
11041                 }
11042                 pRExC_state->code_index++;
11043                 nextchar(pRExC_state);
11044
11045                 if (is_logical) {
11046                     regnode *eval;
11047                     ret = reg_node(pRExC_state, LOGICAL);
11048
11049                     eval = reg2Lanode(pRExC_state, EVAL,
11050                                        n,
11051
11052                                        /* for later propagation into (??{})
11053                                         * return value */
11054                                        RExC_flags & RXf_PMf_COMPILETIME
11055                                       );
11056                     if (!SIZE_ONLY) {
11057                         ret->flags = 2;
11058                     }
11059                     REGTAIL(pRExC_state, ret, eval);
11060                     /* deal with the length of this later - MJD */
11061                     return ret;
11062                 }
11063                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11064                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
11065                 Set_Node_Offset(ret, parse_start);
11066                 return ret;
11067             }
11068             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11069             {
11070                 int is_define= 0;
11071                 const int DEFINE_len = sizeof("DEFINE") - 1;
11072                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
11073                     if (   RExC_parse < RExC_end - 1
11074                         && (   RExC_parse[1] == '='
11075                             || RExC_parse[1] == '!'
11076                             || RExC_parse[1] == '<'
11077                             || RExC_parse[1] == '{')
11078                     ) { /* Lookahead or eval. */
11079                         I32 flag;
11080                         regnode *tail;
11081
11082                         ret = reg_node(pRExC_state, LOGICAL);
11083                         if (!SIZE_ONLY)
11084                             ret->flags = 1;
11085
11086                         tail = reg(pRExC_state, 1, &flag, depth+1);
11087                         if (flag & (RESTART_PASS1|NEED_UTF8)) {
11088                             *flagp = flag & (RESTART_PASS1|NEED_UTF8);
11089                             return NULL;
11090                         }
11091                         REGTAIL(pRExC_state, ret, tail);
11092                         goto insert_if;
11093                     }
11094                     /* Fall through to ‘Unknown switch condition’ at the
11095                        end of the if/else chain. */
11096                 }
11097                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11098                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11099                 {
11100                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11101                     char *name_start= RExC_parse++;
11102                     U32 num = 0;
11103                     SV *sv_dat=reg_scan_name(pRExC_state,
11104                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11105                     if (   RExC_parse == name_start
11106                         || RExC_parse >= RExC_end
11107                         || *RExC_parse != ch)
11108                     {
11109                         vFAIL2("Sequence (?(%c... not terminated",
11110                             (ch == '>' ? '<' : ch));
11111                     }
11112                     RExC_parse++;
11113                     if (!SIZE_ONLY) {
11114                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11115                         RExC_rxi->data->data[num]=(void*)sv_dat;
11116                         SvREFCNT_inc_simple_void(sv_dat);
11117                     }
11118                     ret = reganode(pRExC_state,NGROUPP,num);
11119                     goto insert_if_check_paren;
11120                 }
11121                 else if (RExC_end - RExC_parse >= DEFINE_len
11122                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
11123                 {
11124                     ret = reganode(pRExC_state,DEFINEP,0);
11125                     RExC_parse += DEFINE_len;
11126                     is_define = 1;
11127                     goto insert_if_check_paren;
11128                 }
11129                 else if (RExC_parse[0] == 'R') {
11130                     RExC_parse++;
11131                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11132                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11133                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11134                      */
11135                     parno = 0;
11136                     if (RExC_parse[0] == '0') {
11137                         parno = 1;
11138                         RExC_parse++;
11139                     }
11140                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11141                         UV uv;
11142                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11143                             && uv <= I32_MAX
11144                         ) {
11145                             parno = (I32)uv + 1;
11146                             RExC_parse = (char*)endptr;
11147                         }
11148                         /* else "Switch condition not recognized" below */
11149                     } else if (RExC_parse[0] == '&') {
11150                         SV *sv_dat;
11151                         RExC_parse++;
11152                         sv_dat = reg_scan_name(pRExC_state,
11153                             SIZE_ONLY
11154                             ? REG_RSN_RETURN_NULL
11155                             : REG_RSN_RETURN_DATA);
11156
11157                         /* we should only have a false sv_dat when
11158                          * SIZE_ONLY is true, and we always have false
11159                          * sv_dat when SIZE_ONLY is true.
11160                          * reg_scan_name() will VFAIL() if the name is
11161                          * unknown when SIZE_ONLY is false, and otherwise
11162                          * will return something, and when SIZE_ONLY is
11163                          * true, reg_scan_name() just parses the string,
11164                          * and doesnt return anything. (in theory) */
11165                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
11166
11167                         if (sv_dat)
11168                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11169                     }
11170                     ret = reganode(pRExC_state,INSUBP,parno);
11171                     goto insert_if_check_paren;
11172                 }
11173                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11174                     /* (?(1)...) */
11175                     char c;
11176                     UV uv;
11177                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11178                         && uv <= I32_MAX
11179                     ) {
11180                         parno = (I32)uv;
11181                         RExC_parse = (char*)endptr;
11182                     }
11183                     else {
11184                         vFAIL("panic: grok_atoUV returned FALSE");
11185                     }
11186                     ret = reganode(pRExC_state, GROUPP, parno);
11187
11188                  insert_if_check_paren:
11189                     if (UCHARAT(RExC_parse) != ')') {
11190                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11191                         vFAIL("Switch condition not recognized");
11192                     }
11193                     nextchar(pRExC_state);
11194                   insert_if:
11195                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11196                     br = regbranch(pRExC_state, &flags, 1,depth+1);
11197                     if (br == NULL) {
11198                         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11199                             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11200                             return NULL;
11201                         }
11202                         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11203                               (UV) flags);
11204                     } else
11205                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11206                                                           LONGJMP, 0));
11207                     c = UCHARAT(RExC_parse);
11208                     nextchar(pRExC_state);
11209                     if (flags&HASWIDTH)
11210                         *flagp |= HASWIDTH;
11211                     if (c == '|') {
11212                         if (is_define)
11213                             vFAIL("(?(DEFINE)....) does not allow branches");
11214
11215                         /* Fake one for optimizer.  */
11216                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11217
11218                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
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                         }
11226                         REGTAIL(pRExC_state, ret, lastbr);
11227                         if (flags&HASWIDTH)
11228                             *flagp |= HASWIDTH;
11229                         c = UCHARAT(RExC_parse);
11230                         nextchar(pRExC_state);
11231                     }
11232                     else
11233                         lastbr = NULL;
11234                     if (c != ')') {
11235                         if (RExC_parse >= RExC_end)
11236                             vFAIL("Switch (?(condition)... not terminated");
11237                         else
11238                             vFAIL("Switch (?(condition)... contains too many branches");
11239                     }
11240                     ender = reg_node(pRExC_state, TAIL);
11241                     REGTAIL(pRExC_state, br, ender);
11242                     if (lastbr) {
11243                         REGTAIL(pRExC_state, lastbr, ender);
11244                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11245                     }
11246                     else
11247                         REGTAIL(pRExC_state, ret, ender);
11248                     RExC_size++; /* XXX WHY do we need this?!!
11249                                     For large programs it seems to be required
11250                                     but I can't figure out why. -- dmq*/
11251                     return ret;
11252                 }
11253                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11254                 vFAIL("Unknown switch condition (?(...))");
11255             }
11256             case '[':           /* (?[ ... ]) */
11257                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
11258                                          oregcomp_parse);
11259             case 0: /* A NUL */
11260                 RExC_parse--; /* for vFAIL to print correctly */
11261                 vFAIL("Sequence (? incomplete");
11262                 break;
11263             default: /* e.g., (?i) */
11264                 RExC_parse = (char *) seqstart + 1;
11265               parse_flags:
11266                 parse_lparen_question_flags(pRExC_state);
11267                 if (UCHARAT(RExC_parse) != ':') {
11268                     if (RExC_parse < RExC_end)
11269                         nextchar(pRExC_state);
11270                     *flagp = TRYAGAIN;
11271                     return NULL;
11272                 }
11273                 paren = ':';
11274                 nextchar(pRExC_state);
11275                 ret = NULL;
11276                 goto parse_rest;
11277             } /* end switch */
11278         }
11279         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11280           capturing_parens:
11281             parno = RExC_npar;
11282             RExC_npar++;
11283
11284             ret = reganode(pRExC_state, OPEN, parno);
11285             if (!SIZE_ONLY ){
11286                 if (!RExC_nestroot)
11287                     RExC_nestroot = parno;
11288                 if (RExC_open_parens && !RExC_open_parens[parno])
11289                 {
11290                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11291                         "%*s%*s Setting open paren #%" IVdf " to %d\n",
11292                         22, "|    |", (int)(depth * 2 + 1), "",
11293                         (IV)parno, REG_NODE_NUM(ret)));
11294                     RExC_open_parens[parno]= ret;
11295                 }
11296             }
11297             Set_Node_Length(ret, 1); /* MJD */
11298             Set_Node_Offset(ret, RExC_parse); /* MJD */
11299             is_open = 1;
11300         } else {
11301             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11302             paren = ':';
11303             ret = NULL;
11304         }
11305     }
11306     else                        /* ! paren */
11307         ret = NULL;
11308
11309    parse_rest:
11310     /* Pick up the branches, linking them together. */
11311     parse_start = RExC_parse;   /* MJD */
11312     br = regbranch(pRExC_state, &flags, 1,depth+1);
11313
11314     /*     branch_len = (paren != 0); */
11315
11316     if (br == NULL) {
11317         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11318             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11319             return NULL;
11320         }
11321         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11322     }
11323     if (*RExC_parse == '|') {
11324         if (!SIZE_ONLY && RExC_extralen) {
11325             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11326         }
11327         else {                  /* MJD */
11328             reginsert(pRExC_state, BRANCH, br, depth+1);
11329             Set_Node_Length(br, paren != 0);
11330             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11331         }
11332         have_branch = 1;
11333         if (SIZE_ONLY)
11334             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11335     }
11336     else if (paren == ':') {
11337         *flagp |= flags&SIMPLE;
11338     }
11339     if (is_open) {                              /* Starts with OPEN. */
11340         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11341     }
11342     else if (paren != '?')              /* Not Conditional */
11343         ret = br;
11344     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11345     lastbr = br;
11346     while (*RExC_parse == '|') {
11347         if (!SIZE_ONLY && RExC_extralen) {
11348             ender = reganode(pRExC_state, LONGJMP,0);
11349
11350             /* Append to the previous. */
11351             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11352         }
11353         if (SIZE_ONLY)
11354             RExC_extralen += 2;         /* Account for LONGJMP. */
11355         nextchar(pRExC_state);
11356         if (freeze_paren) {
11357             if (RExC_npar > after_freeze)
11358                 after_freeze = RExC_npar;
11359             RExC_npar = freeze_paren;
11360         }
11361         br = regbranch(pRExC_state, &flags, 0, depth+1);
11362
11363         if (br == NULL) {
11364             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11365                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11366                 return NULL;
11367             }
11368             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11369         }
11370         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11371         lastbr = br;
11372         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11373     }
11374
11375     if (have_branch || paren != ':') {
11376         /* Make a closing node, and hook it on the end. */
11377         switch (paren) {
11378         case ':':
11379             ender = reg_node(pRExC_state, TAIL);
11380             break;
11381         case 1: case 2:
11382             ender = reganode(pRExC_state, CLOSE, parno);
11383             if ( RExC_close_parens ) {
11384                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11385                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
11386                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11387                 RExC_close_parens[parno]= ender;
11388                 if (RExC_nestroot == parno)
11389                     RExC_nestroot = 0;
11390             }
11391             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11392             Set_Node_Length(ender,1); /* MJD */
11393             break;
11394         case '<':
11395         case ',':
11396         case '=':
11397         case '!':
11398             *flagp &= ~HASWIDTH;
11399             /* FALLTHROUGH */
11400         case '>':
11401             ender = reg_node(pRExC_state, SUCCEED);
11402             break;
11403         case 0:
11404             ender = reg_node(pRExC_state, END);
11405             if (!SIZE_ONLY) {
11406                 assert(!RExC_end_op); /* there can only be one! */
11407                 RExC_end_op = ender;
11408                 if (RExC_close_parens) {
11409                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11410                         "%*s%*s Setting close paren #0 (END) to %d\n",
11411                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11412
11413                     RExC_close_parens[0]= ender;
11414                 }
11415             }
11416             break;
11417         }
11418         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11419             DEBUG_PARSE_MSG("lsbr");
11420             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11421             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11422             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11423                           SvPV_nolen_const(RExC_mysv1),
11424                           (IV)REG_NODE_NUM(lastbr),
11425                           SvPV_nolen_const(RExC_mysv2),
11426                           (IV)REG_NODE_NUM(ender),
11427                           (IV)(ender - lastbr)
11428             );
11429         });
11430         REGTAIL(pRExC_state, lastbr, ender);
11431
11432         if (have_branch && !SIZE_ONLY) {
11433             char is_nothing= 1;
11434             if (depth==1)
11435                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11436
11437             /* Hook the tails of the branches to the closing node. */
11438             for (br = ret; br; br = regnext(br)) {
11439                 const U8 op = PL_regkind[OP(br)];
11440                 if (op == BRANCH) {
11441                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11442                     if ( OP(NEXTOPER(br)) != NOTHING
11443                          || regnext(NEXTOPER(br)) != ender)
11444                         is_nothing= 0;
11445                 }
11446                 else if (op == BRANCHJ) {
11447                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11448                     /* for now we always disable this optimisation * /
11449                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11450                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11451                     */
11452                         is_nothing= 0;
11453                 }
11454             }
11455             if (is_nothing) {
11456                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11457                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11458                     DEBUG_PARSE_MSG("NADA");
11459                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11460                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11461                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11462                                   SvPV_nolen_const(RExC_mysv1),
11463                                   (IV)REG_NODE_NUM(ret),
11464                                   SvPV_nolen_const(RExC_mysv2),
11465                                   (IV)REG_NODE_NUM(ender),
11466                                   (IV)(ender - ret)
11467                     );
11468                 });
11469                 OP(br)= NOTHING;
11470                 if (OP(ender) == TAIL) {
11471                     NEXT_OFF(br)= 0;
11472                     RExC_emit= br + 1;
11473                 } else {
11474                     regnode *opt;
11475                     for ( opt= br + 1; opt < ender ; opt++ )
11476                         OP(opt)= OPTIMIZED;
11477                     NEXT_OFF(br)= ender - br;
11478                 }
11479             }
11480         }
11481     }
11482
11483     {
11484         const char *p;
11485         static const char parens[] = "=!<,>";
11486
11487         if (paren && (p = strchr(parens, paren))) {
11488             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11489             int flag = (p - parens) > 1;
11490
11491             if (paren == '>')
11492                 node = SUSPEND, flag = 0;
11493             reginsert(pRExC_state, node,ret, depth+1);
11494             Set_Node_Cur_Length(ret, parse_start);
11495             Set_Node_Offset(ret, parse_start + 1);
11496             ret->flags = flag;
11497             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11498         }
11499     }
11500
11501     /* Check for proper termination. */
11502     if (paren) {
11503         /* restore original flags, but keep (?p) and, if we've changed from /d
11504          * rules to /u, keep the /u */
11505         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11506         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11507             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11508         }
11509         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11510             RExC_parse = oregcomp_parse;
11511             vFAIL("Unmatched (");
11512         }
11513         nextchar(pRExC_state);
11514     }
11515     else if (!paren && RExC_parse < RExC_end) {
11516         if (*RExC_parse == ')') {
11517             RExC_parse++;
11518             vFAIL("Unmatched )");
11519         }
11520         else
11521             FAIL("Junk on end of regexp");      /* "Can't happen". */
11522         NOT_REACHED; /* NOTREACHED */
11523     }
11524
11525     if (RExC_in_lookbehind) {
11526         RExC_in_lookbehind--;
11527     }
11528     if (after_freeze > RExC_npar)
11529         RExC_npar = after_freeze;
11530     return(ret);
11531 }
11532
11533 /*
11534  - regbranch - one alternative of an | operator
11535  *
11536  * Implements the concatenation operator.
11537  *
11538  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11539  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11540  */
11541 STATIC regnode *
11542 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11543 {
11544     regnode *ret;
11545     regnode *chain = NULL;
11546     regnode *latest;
11547     I32 flags = 0, c = 0;
11548     GET_RE_DEBUG_FLAGS_DECL;
11549
11550     PERL_ARGS_ASSERT_REGBRANCH;
11551
11552     DEBUG_PARSE("brnc");
11553
11554     if (first)
11555         ret = NULL;
11556     else {
11557         if (!SIZE_ONLY && RExC_extralen)
11558             ret = reganode(pRExC_state, BRANCHJ,0);
11559         else {
11560             ret = reg_node(pRExC_state, BRANCH);
11561             Set_Node_Length(ret, 1);
11562         }
11563     }
11564
11565     if (!first && SIZE_ONLY)
11566         RExC_extralen += 1;                     /* BRANCHJ */
11567
11568     *flagp = WORST;                     /* Tentatively. */
11569
11570     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11571                             FALSE /* Don't force to /x */ );
11572     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11573         flags &= ~TRYAGAIN;
11574         latest = regpiece(pRExC_state, &flags,depth+1);
11575         if (latest == NULL) {
11576             if (flags & TRYAGAIN)
11577                 continue;
11578             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11579                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11580                 return NULL;
11581             }
11582             FAIL2("panic: regpiece returned NULL, flags=%#" UVxf, (UV) flags);
11583         }
11584         else if (ret == NULL)
11585             ret = latest;
11586         *flagp |= flags&(HASWIDTH|POSTPONED);
11587         if (chain == NULL)      /* First piece. */
11588             *flagp |= flags&SPSTART;
11589         else {
11590             /* FIXME adding one for every branch after the first is probably
11591              * excessive now we have TRIE support. (hv) */
11592             MARK_NAUGHTY(1);
11593             REGTAIL(pRExC_state, chain, latest);
11594         }
11595         chain = latest;
11596         c++;
11597     }
11598     if (chain == NULL) {        /* Loop ran zero times. */
11599         chain = reg_node(pRExC_state, NOTHING);
11600         if (ret == NULL)
11601             ret = chain;
11602     }
11603     if (c == 1) {
11604         *flagp |= flags&SIMPLE;
11605     }
11606
11607     return ret;
11608 }
11609
11610 /*
11611  - regpiece - something followed by possible [*+?]
11612  *
11613  * Note that the branching code sequences used for ? and the general cases
11614  * of * and + are somewhat optimized:  they use the same NOTHING node as
11615  * both the endmarker for their branch list and the body of the last branch.
11616  * It might seem that this node could be dispensed with entirely, but the
11617  * endmarker role is not redundant.
11618  *
11619  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11620  * TRYAGAIN.
11621  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11622  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11623  */
11624 STATIC regnode *
11625 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11626 {
11627     regnode *ret;
11628     char op;
11629     char *next;
11630     I32 flags;
11631     const char * const origparse = RExC_parse;
11632     I32 min;
11633     I32 max = REG_INFTY;
11634 #ifdef RE_TRACK_PATTERN_OFFSETS
11635     char *parse_start;
11636 #endif
11637     const char *maxpos = NULL;
11638     UV uv;
11639
11640     /* Save the original in case we change the emitted regop to a FAIL. */
11641     regnode * const orig_emit = RExC_emit;
11642
11643     GET_RE_DEBUG_FLAGS_DECL;
11644
11645     PERL_ARGS_ASSERT_REGPIECE;
11646
11647     DEBUG_PARSE("piec");
11648
11649     ret = regatom(pRExC_state, &flags,depth+1);
11650     if (ret == NULL) {
11651         if (flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8))
11652             *flagp |= flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8);
11653         else
11654             FAIL2("panic: regatom returned NULL, flags=%#" UVxf, (UV) flags);
11655         return(NULL);
11656     }
11657
11658     op = *RExC_parse;
11659
11660     if (op == '{' && regcurly(RExC_parse)) {
11661         maxpos = NULL;
11662 #ifdef RE_TRACK_PATTERN_OFFSETS
11663         parse_start = RExC_parse; /* MJD */
11664 #endif
11665         next = RExC_parse + 1;
11666         while (isDIGIT(*next) || *next == ',') {
11667             if (*next == ',') {
11668                 if (maxpos)
11669                     break;
11670                 else
11671                     maxpos = next;
11672             }
11673             next++;
11674         }
11675         if (*next == '}') {             /* got one */
11676             const char* endptr;
11677             if (!maxpos)
11678                 maxpos = next;
11679             RExC_parse++;
11680             if (isDIGIT(*RExC_parse)) {
11681                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
11682                     vFAIL("Invalid quantifier in {,}");
11683                 if (uv >= REG_INFTY)
11684                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11685                 min = (I32)uv;
11686             } else {
11687                 min = 0;
11688             }
11689             if (*maxpos == ',')
11690                 maxpos++;
11691             else
11692                 maxpos = RExC_parse;
11693             if (isDIGIT(*maxpos)) {
11694                 if (!grok_atoUV(maxpos, &uv, &endptr))
11695                     vFAIL("Invalid quantifier in {,}");
11696                 if (uv >= REG_INFTY)
11697                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11698                 max = (I32)uv;
11699             } else {
11700                 max = REG_INFTY;                /* meaning "infinity" */
11701             }
11702             RExC_parse = next;
11703             nextchar(pRExC_state);
11704             if (max < min) {    /* If can't match, warn and optimize to fail
11705                                    unconditionally */
11706                 if (SIZE_ONLY) {
11707
11708                     /* We can't back off the size because we have to reserve
11709                      * enough space for all the things we are about to throw
11710                      * away, but we can shrink it by the amount we are about
11711                      * to re-use here */
11712                     RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
11713                 }
11714                 else {
11715                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
11716                     RExC_emit = orig_emit;
11717                 }
11718                 ret = reganode(pRExC_state, OPFAIL, 0);
11719                 return ret;
11720             }
11721             else if (min == max && *RExC_parse == '?')
11722             {
11723                 if (PASS2) {
11724                     ckWARN2reg(RExC_parse + 1,
11725                                "Useless use of greediness modifier '%c'",
11726                                *RExC_parse);
11727                 }
11728             }
11729
11730           do_curly:
11731             if ((flags&SIMPLE)) {
11732                 if (min == 0 && max == REG_INFTY) {
11733                     reginsert(pRExC_state, STAR, ret, depth+1);
11734                     ret->flags = 0;
11735                     MARK_NAUGHTY(4);
11736                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11737                     goto nest_check;
11738                 }
11739                 if (min == 1 && max == REG_INFTY) {
11740                     reginsert(pRExC_state, PLUS, ret, depth+1);
11741                     ret->flags = 0;
11742                     MARK_NAUGHTY(3);
11743                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11744                     goto nest_check;
11745                 }
11746                 MARK_NAUGHTY_EXP(2, 2);
11747                 reginsert(pRExC_state, CURLY, ret, depth+1);
11748                 Set_Node_Offset(ret, parse_start+1); /* MJD */
11749                 Set_Node_Cur_Length(ret, parse_start);
11750             }
11751             else {
11752                 regnode * const w = reg_node(pRExC_state, WHILEM);
11753
11754                 w->flags = 0;
11755                 REGTAIL(pRExC_state, ret, w);
11756                 if (!SIZE_ONLY && RExC_extralen) {
11757                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
11758                     reginsert(pRExC_state, NOTHING,ret, depth+1);
11759                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
11760                 }
11761                 reginsert(pRExC_state, CURLYX,ret, depth+1);
11762                                 /* MJD hk */
11763                 Set_Node_Offset(ret, parse_start+1);
11764                 Set_Node_Length(ret,
11765                                 op == '{' ? (RExC_parse - parse_start) : 1);
11766
11767                 if (!SIZE_ONLY && RExC_extralen)
11768                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
11769                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
11770                 if (SIZE_ONLY)
11771                     RExC_whilem_seen++, RExC_extralen += 3;
11772                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
11773             }
11774             ret->flags = 0;
11775
11776             if (min > 0)
11777                 *flagp = WORST;
11778             if (max > 0)
11779                 *flagp |= HASWIDTH;
11780             if (!SIZE_ONLY) {
11781                 ARG1_SET(ret, (U16)min);
11782                 ARG2_SET(ret, (U16)max);
11783             }
11784             if (max == REG_INFTY)
11785                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11786
11787             goto nest_check;
11788         }
11789     }
11790
11791     if (!ISMULT1(op)) {
11792         *flagp = flags;
11793         return(ret);
11794     }
11795
11796 #if 0                           /* Now runtime fix should be reliable. */
11797
11798     /* if this is reinstated, don't forget to put this back into perldiag:
11799
11800             =item Regexp *+ operand could be empty at {#} in regex m/%s/
11801
11802            (F) The part of the regexp subject to either the * or + quantifier
11803            could match an empty string. The {#} shows in the regular
11804            expression about where the problem was discovered.
11805
11806     */
11807
11808     if (!(flags&HASWIDTH) && op != '?')
11809       vFAIL("Regexp *+ operand could be empty");
11810 #endif
11811
11812 #ifdef RE_TRACK_PATTERN_OFFSETS
11813     parse_start = RExC_parse;
11814 #endif
11815     nextchar(pRExC_state);
11816
11817     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
11818
11819     if (op == '*') {
11820         min = 0;
11821         goto do_curly;
11822     }
11823     else if (op == '+') {
11824         min = 1;
11825         goto do_curly;
11826     }
11827     else if (op == '?') {
11828         min = 0; max = 1;
11829         goto do_curly;
11830     }
11831   nest_check:
11832     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
11833         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11834         ckWARN2reg(RExC_parse,
11835                    "%" UTF8f " matches null string many times",
11836                    UTF8fARG(UTF, (RExC_parse >= origparse
11837                                  ? RExC_parse - origparse
11838                                  : 0),
11839                    origparse));
11840         (void)ReREFCNT_inc(RExC_rx_sv);
11841     }
11842
11843     if (*RExC_parse == '?') {
11844         nextchar(pRExC_state);
11845         reginsert(pRExC_state, MINMOD, ret, depth+1);
11846         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11847     }
11848     else if (*RExC_parse == '+') {
11849         regnode *ender;
11850         nextchar(pRExC_state);
11851         ender = reg_node(pRExC_state, SUCCEED);
11852         REGTAIL(pRExC_state, ret, ender);
11853         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11854         ret->flags = 0;
11855         ender = reg_node(pRExC_state, TAIL);
11856         REGTAIL(pRExC_state, ret, ender);
11857     }
11858
11859     if (ISMULT2(RExC_parse)) {
11860         RExC_parse++;
11861         vFAIL("Nested quantifiers");
11862     }
11863
11864     return(ret);
11865 }
11866
11867 STATIC bool
11868 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11869                 regnode ** node_p,
11870                 UV * code_point_p,
11871                 int * cp_count,
11872                 I32 * flagp,
11873                 const bool strict,
11874                 const U32 depth
11875     )
11876 {
11877  /* This routine teases apart the various meanings of \N and returns
11878   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11879   * in the current context.
11880   *
11881   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11882   *
11883   * If <code_point_p> is not NULL, the context is expecting the result to be a
11884   * single code point.  If this \N instance turns out to a single code point,
11885   * the function returns TRUE and sets *code_point_p to that code point.
11886   *
11887   * If <node_p> is not NULL, the context is expecting the result to be one of
11888   * the things representable by a regnode.  If this \N instance turns out to be
11889   * one such, the function generates the regnode, returns TRUE and sets *node_p
11890   * to point to that regnode.
11891   *
11892   * If this instance of \N isn't legal in any context, this function will
11893   * generate a fatal error and not return.
11894   *
11895   * On input, RExC_parse should point to the first char following the \N at the
11896   * time of the call.  On successful return, RExC_parse will have been updated
11897   * to point to just after the sequence identified by this routine.  Also
11898   * *flagp has been updated as needed.
11899   *
11900   * When there is some problem with the current context and this \N instance,
11901   * the function returns FALSE, without advancing RExC_parse, nor setting
11902   * *node_p, nor *code_point_p, nor *flagp.
11903   *
11904   * If <cp_count> is not NULL, the caller wants to know the length (in code
11905   * points) that this \N sequence matches.  This is set even if the function
11906   * returns FALSE, as detailed below.
11907   *
11908   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11909   *
11910   * Probably the most common case is for the \N to specify a single code point.
11911   * *cp_count will be set to 1, and *code_point_p will be set to that code
11912   * point.
11913   *
11914   * Another possibility is for the input to be an empty \N{}, which for
11915   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11916   * will be set to a generated NOTHING node.
11917   *
11918   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11919   * set to 0. *node_p will be set to a generated REG_ANY node.
11920   *
11921   * The fourth possibility is that \N resolves to a sequence of more than one
11922   * code points.  *cp_count will be set to the number of code points in the
11923   * sequence. *node_p * will be set to a generated node returned by this
11924   * function calling S_reg().
11925   *
11926   * The final possibility is that it is premature to be calling this function;
11927   * that pass1 needs to be restarted.  This can happen when this changes from
11928   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
11929   * latter occurs only when the fourth possibility would otherwise be in
11930   * effect, and is because one of those code points requires the pattern to be
11931   * recompiled as UTF-8.  The function returns FALSE, and sets the
11932   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
11933   * happens, the caller needs to desist from continuing parsing, and return
11934   * this information to its caller.  This is not set for when there is only one
11935   * code point, as this can be called as part of an ANYOF node, and they can
11936   * store above-Latin1 code points without the pattern having to be in UTF-8.
11937   *
11938   * For non-single-quoted regexes, the tokenizer has resolved character and
11939   * sequence names inside \N{...} into their Unicode values, normalizing the
11940   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11941   * hex-represented code points in the sequence.  This is done there because
11942   * the names can vary based on what charnames pragma is in scope at the time,
11943   * so we need a way to take a snapshot of what they resolve to at the time of
11944   * the original parse. [perl #56444].
11945   *
11946   * That parsing is skipped for single-quoted regexes, so we may here get
11947   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11948   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11949   * is legal and handled here.  The code point is Unicode, and has to be
11950   * translated into the native character set for non-ASCII platforms.
11951   */
11952
11953     char * endbrace;    /* points to '}' following the name */
11954     char *endchar;      /* Points to '.' or '}' ending cur char in the input
11955                            stream */
11956     char* p = RExC_parse; /* Temporary */
11957
11958     GET_RE_DEBUG_FLAGS_DECL;
11959
11960     PERL_ARGS_ASSERT_GROK_BSLASH_N;
11961
11962     GET_RE_DEBUG_FLAGS;
11963
11964     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
11965     assert(! (node_p && cp_count));               /* At most 1 should be set */
11966
11967     if (cp_count) {     /* Initialize return for the most common case */
11968         *cp_count = 1;
11969     }
11970
11971     /* The [^\n] meaning of \N ignores spaces and comments under the /x
11972      * modifier.  The other meanings do not, so use a temporary until we find
11973      * out which we are being called with */
11974     skip_to_be_ignored_text(pRExC_state, &p,
11975                             FALSE /* Don't force to /x */ );
11976
11977     /* Disambiguate between \N meaning a named character versus \N meaning
11978      * [^\n].  The latter is assumed when the {...} following the \N is a legal
11979      * quantifier, or there is no '{' at all */
11980     if (*p != '{' || regcurly(p)) {
11981         RExC_parse = p;
11982         if (cp_count) {
11983             *cp_count = -1;
11984         }
11985
11986         if (! node_p) {
11987             return FALSE;
11988         }
11989
11990         *node_p = reg_node(pRExC_state, REG_ANY);
11991         *flagp |= HASWIDTH|SIMPLE;
11992         MARK_NAUGHTY(1);
11993         Set_Node_Length(*node_p, 1); /* MJD */
11994         return TRUE;
11995     }
11996
11997     /* Here, we have decided it should be a named character or sequence */
11998
11999     /* The test above made sure that the next real character is a '{', but
12000      * under the /x modifier, it could be separated by space (or a comment and
12001      * \n) and this is not allowed (for consistency with \x{...} and the
12002      * tokenizer handling of \N{NAME}). */
12003     if (*RExC_parse != '{') {
12004         vFAIL("Missing braces on \\N{}");
12005     }
12006
12007     RExC_parse++;       /* Skip past the '{' */
12008
12009     if (! (endbrace = strchr(RExC_parse, '}'))) { /* no trailing brace */
12010         vFAIL2("Missing right brace on \\%c{}", 'N');
12011     }
12012     else if(!(endbrace == RExC_parse            /* nothing between the {} */
12013               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
12014                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
12015                                                        error msg) */
12016     {
12017         RExC_parse = endbrace;  /* position msg's '<--HERE' */
12018         vFAIL("\\N{NAME} must be resolved by the lexer");
12019     }
12020
12021     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
12022                                         semantics */
12023
12024     if (endbrace == RExC_parse) {   /* empty: \N{} */
12025         if (strict) {
12026             RExC_parse++;   /* Position after the "}" */
12027             vFAIL("Zero length \\N{}");
12028         }
12029         if (cp_count) {
12030             *cp_count = 0;
12031         }
12032         nextchar(pRExC_state);
12033         if (! node_p) {
12034             return FALSE;
12035         }
12036
12037         *node_p = reg_node(pRExC_state,NOTHING);
12038         return TRUE;
12039     }
12040
12041     RExC_parse += 2;    /* Skip past the 'U+' */
12042
12043     /* Because toke.c has generated a special construct for us guaranteed not
12044      * to have NULs, we can use a str function */
12045     endchar = RExC_parse + strcspn(RExC_parse, ".}");
12046
12047     /* Code points are separated by dots.  If none, there is only one code
12048      * point, and is terminated by the brace */
12049
12050     if (endchar >= endbrace) {
12051         STRLEN length_of_hex;
12052         I32 grok_hex_flags;
12053
12054         /* Here, exactly one code point.  If that isn't what is wanted, fail */
12055         if (! code_point_p) {
12056             RExC_parse = p;
12057             return FALSE;
12058         }
12059
12060         /* Convert code point from hex */
12061         length_of_hex = (STRLEN)(endchar - RExC_parse);
12062         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
12063                            | PERL_SCAN_DISALLOW_PREFIX
12064
12065                              /* No errors in the first pass (See [perl
12066                               * #122671].)  We let the code below find the
12067                               * errors when there are multiple chars. */
12068                            | ((SIZE_ONLY)
12069                               ? PERL_SCAN_SILENT_ILLDIGIT
12070                               : 0);
12071
12072         /* This routine is the one place where both single- and double-quotish
12073          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
12074          * must be converted to native. */
12075         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
12076                                          &length_of_hex,
12077                                          &grok_hex_flags,
12078                                          NULL));
12079
12080         /* The tokenizer should have guaranteed validity, but it's possible to
12081          * bypass it by using single quoting, so check.  Don't do the check
12082          * here when there are multiple chars; we do it below anyway. */
12083         if (length_of_hex == 0
12084             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
12085         {
12086             RExC_parse += length_of_hex;        /* Includes all the valid */
12087             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
12088                             ? UTF8SKIP(RExC_parse)
12089                             : 1;
12090             /* Guard against malformed utf8 */
12091             if (RExC_parse >= endchar) {
12092                 RExC_parse = endchar;
12093             }
12094             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12095         }
12096
12097         RExC_parse = endbrace + 1;
12098         return TRUE;
12099     }
12100     else {  /* Is a multiple character sequence */
12101         SV * substitute_parse;
12102         STRLEN len;
12103         char *orig_end = RExC_end;
12104         char *save_start = RExC_start;
12105         I32 flags;
12106
12107         /* Count the code points, if desired, in the sequence */
12108         if (cp_count) {
12109             *cp_count = 0;
12110             while (RExC_parse < endbrace) {
12111                 /* Point to the beginning of the next character in the sequence. */
12112                 RExC_parse = endchar + 1;
12113                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
12114                 (*cp_count)++;
12115             }
12116         }
12117
12118         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12119          * But don't backup up the pointer if the caller want to know how many
12120          * code points there are (they can then handle things) */
12121         if (! node_p) {
12122             if (! cp_count) {
12123                 RExC_parse = p;
12124             }
12125             return FALSE;
12126         }
12127
12128         /* What is done here is to convert this to a sub-pattern of the form
12129          * \x{char1}\x{char2}...  and then call reg recursively to parse it
12130          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
12131          * while not having to worry about special handling that some code
12132          * points may have. */
12133
12134         substitute_parse = newSVpvs("?:");
12135
12136         while (RExC_parse < endbrace) {
12137
12138             /* Convert to notation the rest of the code understands */
12139             sv_catpv(substitute_parse, "\\x{");
12140             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
12141             sv_catpv(substitute_parse, "}");
12142
12143             /* Point to the beginning of the next character in the sequence. */
12144             RExC_parse = endchar + 1;
12145             endchar = RExC_parse + strcspn(RExC_parse, ".}");
12146
12147         }
12148         sv_catpv(substitute_parse, ")");
12149
12150         RExC_parse = RExC_start = RExC_adjusted_start = SvPV(substitute_parse,
12151                                                              len);
12152
12153         /* Don't allow empty number */
12154         if (len < (STRLEN) 8) {
12155             RExC_parse = endbrace;
12156             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12157         }
12158         RExC_end = RExC_parse + len;
12159
12160         /* The values are Unicode, and therefore not subject to recoding, but
12161          * have to be converted to native on a non-Unicode (meaning non-ASCII)
12162          * platform. */
12163         RExC_override_recoding = 1;
12164 #ifdef EBCDIC
12165         RExC_recode_x_to_native = 1;
12166 #endif
12167
12168         if (node_p) {
12169             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
12170                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12171                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12172                     return FALSE;
12173                 }
12174                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#" UVxf,
12175                     (UV) flags);
12176             }
12177             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12178         }
12179
12180         /* Restore the saved values */
12181         RExC_start = RExC_adjusted_start = save_start;
12182         RExC_parse = endbrace;
12183         RExC_end = orig_end;
12184         RExC_override_recoding = 0;
12185 #ifdef EBCDIC
12186         RExC_recode_x_to_native = 0;
12187 #endif
12188
12189         SvREFCNT_dec_NN(substitute_parse);
12190         nextchar(pRExC_state);
12191
12192         return TRUE;
12193     }
12194 }
12195
12196
12197 PERL_STATIC_INLINE U8
12198 S_compute_EXACTish(RExC_state_t *pRExC_state)
12199 {
12200     U8 op;
12201
12202     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12203
12204     if (! FOLD) {
12205         return (LOC)
12206                 ? EXACTL
12207                 : EXACT;
12208     }
12209
12210     op = get_regex_charset(RExC_flags);
12211     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12212         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12213                  been, so there is no hole */
12214     }
12215
12216     return op + EXACTF;
12217 }
12218
12219 PERL_STATIC_INLINE void
12220 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12221                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12222                          bool downgradable)
12223 {
12224     /* This knows the details about sizing an EXACTish node, setting flags for
12225      * it (by setting <*flagp>, and potentially populating it with a single
12226      * character.
12227      *
12228      * If <len> (the length in bytes) is non-zero, this function assumes that
12229      * the node has already been populated, and just does the sizing.  In this
12230      * case <code_point> should be the final code point that has already been
12231      * placed into the node.  This value will be ignored except that under some
12232      * circumstances <*flagp> is set based on it.
12233      *
12234      * If <len> is zero, the function assumes that the node is to contain only
12235      * the single character given by <code_point> and calculates what <len>
12236      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12237      * additionally will populate the node's STRING with <code_point> or its
12238      * fold if folding.
12239      *
12240      * In both cases <*flagp> is appropriately set
12241      *
12242      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12243      * 255, must be folded (the former only when the rules indicate it can
12244      * match 'ss')
12245      *
12246      * When it does the populating, it looks at the flag 'downgradable'.  If
12247      * true with a node that folds, it checks if the single code point
12248      * participates in a fold, and if not downgrades the node to an EXACT.
12249      * This helps the optimizer */
12250
12251     bool len_passed_in = cBOOL(len != 0);
12252     U8 character[UTF8_MAXBYTES_CASE+1];
12253
12254     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12255
12256     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12257      * sizing difference, and is extra work that is thrown away */
12258     if (downgradable && ! PASS2) {
12259         downgradable = FALSE;
12260     }
12261
12262     if (! len_passed_in) {
12263         if (UTF) {
12264             if (UVCHR_IS_INVARIANT(code_point)) {
12265                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12266                     *character = (U8) code_point;
12267                 }
12268                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12269                           ASCII, which isn't the same thing as INVARIANT on
12270                           EBCDIC, but it works there, as the extra invariants
12271                           fold to themselves) */
12272                     *character = toFOLD((U8) code_point);
12273
12274                     /* We can downgrade to an EXACT node if this character
12275                      * isn't a folding one.  Note that this assumes that
12276                      * nothing above Latin1 folds to some other invariant than
12277                      * one of these alphabetics; otherwise we would also have
12278                      * to check:
12279                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12280                      *      || ASCII_FOLD_RESTRICTED))
12281                      */
12282                     if (downgradable && PL_fold[code_point] == code_point) {
12283                         OP(node) = EXACT;
12284                     }
12285                 }
12286                 len = 1;
12287             }
12288             else if (FOLD && (! LOC
12289                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12290             {   /* Folding, and ok to do so now */
12291                 UV folded = _to_uni_fold_flags(
12292                                    code_point,
12293                                    character,
12294                                    &len,
12295                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12296                                                       ? FOLD_FLAGS_NOMIX_ASCII
12297                                                       : 0));
12298                 if (downgradable
12299                     && folded == code_point /* This quickly rules out many
12300                                                cases, avoiding the
12301                                                _invlist_contains_cp() overhead
12302                                                for those.  */
12303                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12304                 {
12305                     OP(node) = (LOC)
12306                                ? EXACTL
12307                                : EXACT;
12308                 }
12309             }
12310             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12311
12312                 /* Not folding this cp, and can output it directly */
12313                 *character = UTF8_TWO_BYTE_HI(code_point);
12314                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12315                 len = 2;
12316             }
12317             else {
12318                 uvchr_to_utf8( character, code_point);
12319                 len = UTF8SKIP(character);
12320             }
12321         } /* Else pattern isn't UTF8.  */
12322         else if (! FOLD) {
12323             *character = (U8) code_point;
12324             len = 1;
12325         } /* Else is folded non-UTF8 */
12326 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12327    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12328                                       || UNICODE_DOT_DOT_VERSION > 0)
12329         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12330 #else
12331         else if (1) {
12332 #endif
12333             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12334              * comments at join_exact()); */
12335             *character = (U8) code_point;
12336             len = 1;
12337
12338             /* Can turn into an EXACT node if we know the fold at compile time,
12339              * and it folds to itself and doesn't particpate in other folds */
12340             if (downgradable
12341                 && ! LOC
12342                 && PL_fold_latin1[code_point] == code_point
12343                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12344                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12345             {
12346                 OP(node) = EXACT;
12347             }
12348         } /* else is Sharp s.  May need to fold it */
12349         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12350             *character = 's';
12351             *(character + 1) = 's';
12352             len = 2;
12353         }
12354         else {
12355             *character = LATIN_SMALL_LETTER_SHARP_S;
12356             len = 1;
12357         }
12358     }
12359
12360     if (SIZE_ONLY) {
12361         RExC_size += STR_SZ(len);
12362     }
12363     else {
12364         RExC_emit += STR_SZ(len);
12365         STR_LEN(node) = len;
12366         if (! len_passed_in) {
12367             Copy((char *) character, STRING(node), len, char);
12368         }
12369     }
12370
12371     *flagp |= HASWIDTH;
12372
12373     /* A single character node is SIMPLE, except for the special-cased SHARP S
12374      * under /di. */
12375     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12376 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12377    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12378                                       || UNICODE_DOT_DOT_VERSION > 0)
12379         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12380             || ! FOLD || ! DEPENDS_SEMANTICS)
12381 #endif
12382     ) {
12383         *flagp |= SIMPLE;
12384     }
12385
12386     /* The OP may not be well defined in PASS1 */
12387     if (PASS2 && OP(node) == EXACTFL) {
12388         RExC_contains_locale = 1;
12389     }
12390 }
12391
12392
12393 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12394  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12395
12396 static I32
12397 S_backref_value(char *p)
12398 {
12399     const char* endptr;
12400     UV val;
12401     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12402         return (I32)val;
12403     return I32_MAX;
12404 }
12405
12406
12407 /*
12408  - regatom - the lowest level
12409
12410    Try to identify anything special at the start of the current parse position.
12411    If there is, then handle it as required. This may involve generating a
12412    single regop, such as for an assertion; or it may involve recursing, such as
12413    to handle a () structure.
12414
12415    If the string doesn't start with something special then we gobble up
12416    as much literal text as we can.  If we encounter a quantifier, we have to
12417    back off the final literal character, as that quantifier applies to just it
12418    and not to the whole string of literals.
12419
12420    Once we have been able to handle whatever type of thing started the
12421    sequence, we return.
12422
12423    Note: we have to be careful with escapes, as they can be both literal
12424    and special, and in the case of \10 and friends, context determines which.
12425
12426    A summary of the code structure is:
12427
12428    switch (first_byte) {
12429         cases for each special:
12430             handle this special;
12431             break;
12432         case '\\':
12433             switch (2nd byte) {
12434                 cases for each unambiguous special:
12435                     handle this special;
12436                     break;
12437                 cases for each ambigous special/literal:
12438                     disambiguate;
12439                     if (special)  handle here
12440                     else goto defchar;
12441                 default: // unambiguously literal:
12442                     goto defchar;
12443             }
12444         default:  // is a literal char
12445             // FALL THROUGH
12446         defchar:
12447             create EXACTish node for literal;
12448             while (more input and node isn't full) {
12449                 switch (input_byte) {
12450                    cases for each special;
12451                        make sure parse pointer is set so that the next call to
12452                            regatom will see this special first
12453                        goto loopdone; // EXACTish node terminated by prev. char
12454                    default:
12455                        append char to EXACTISH node;
12456                 }
12457                 get next input byte;
12458             }
12459         loopdone:
12460    }
12461    return the generated node;
12462
12463    Specifically there are two separate switches for handling
12464    escape sequences, with the one for handling literal escapes requiring
12465    a dummy entry for all of the special escapes that are actually handled
12466    by the other.
12467
12468    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12469    TRYAGAIN.
12470    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12471    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12472    Otherwise does not return NULL.
12473 */
12474
12475 STATIC regnode *
12476 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12477 {
12478     regnode *ret = NULL;
12479     I32 flags = 0;
12480     char *parse_start;
12481     U8 op;
12482     int invert = 0;
12483     U8 arg;
12484
12485     GET_RE_DEBUG_FLAGS_DECL;
12486
12487     *flagp = WORST;             /* Tentatively. */
12488
12489     DEBUG_PARSE("atom");
12490
12491     PERL_ARGS_ASSERT_REGATOM;
12492
12493   tryagain:
12494     parse_start = RExC_parse;
12495     assert(RExC_parse < RExC_end);
12496     switch ((U8)*RExC_parse) {
12497     case '^':
12498         RExC_seen_zerolen++;
12499         nextchar(pRExC_state);
12500         if (RExC_flags & RXf_PMf_MULTILINE)
12501             ret = reg_node(pRExC_state, MBOL);
12502         else
12503             ret = reg_node(pRExC_state, SBOL);
12504         Set_Node_Length(ret, 1); /* MJD */
12505         break;
12506     case '$':
12507         nextchar(pRExC_state);
12508         if (*RExC_parse)
12509             RExC_seen_zerolen++;
12510         if (RExC_flags & RXf_PMf_MULTILINE)
12511             ret = reg_node(pRExC_state, MEOL);
12512         else
12513             ret = reg_node(pRExC_state, SEOL);
12514         Set_Node_Length(ret, 1); /* MJD */
12515         break;
12516     case '.':
12517         nextchar(pRExC_state);
12518         if (RExC_flags & RXf_PMf_SINGLELINE)
12519             ret = reg_node(pRExC_state, SANY);
12520         else
12521             ret = reg_node(pRExC_state, REG_ANY);
12522         *flagp |= HASWIDTH|SIMPLE;
12523         MARK_NAUGHTY(1);
12524         Set_Node_Length(ret, 1); /* MJD */
12525         break;
12526     case '[':
12527     {
12528         char * const oregcomp_parse = ++RExC_parse;
12529         ret = regclass(pRExC_state, flagp,depth+1,
12530                        FALSE, /* means parse the whole char class */
12531                        TRUE, /* allow multi-char folds */
12532                        FALSE, /* don't silence non-portable warnings. */
12533                        (bool) RExC_strict,
12534                        TRUE, /* Allow an optimized regnode result */
12535                        NULL,
12536                        NULL);
12537         if (ret == NULL) {
12538             if (*flagp & (RESTART_PASS1|NEED_UTF8))
12539                 return NULL;
12540             FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12541                   (UV) *flagp);
12542         }
12543         if (*RExC_parse != ']') {
12544             RExC_parse = oregcomp_parse;
12545             vFAIL("Unmatched [");
12546         }
12547         nextchar(pRExC_state);
12548         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12549         break;
12550     }
12551     case '(':
12552         nextchar(pRExC_state);
12553         ret = reg(pRExC_state, 2, &flags,depth+1);
12554         if (ret == NULL) {
12555                 if (flags & TRYAGAIN) {
12556                     if (RExC_parse >= RExC_end) {
12557                          /* Make parent create an empty node if needed. */
12558                         *flagp |= TRYAGAIN;
12559                         return(NULL);
12560                     }
12561                     goto tryagain;
12562                 }
12563                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12564                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12565                     return NULL;
12566                 }
12567                 FAIL2("panic: reg returned NULL to regatom, flags=%#" UVxf,
12568                                                                  (UV) flags);
12569         }
12570         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12571         break;
12572     case '|':
12573     case ')':
12574         if (flags & TRYAGAIN) {
12575             *flagp |= TRYAGAIN;
12576             return NULL;
12577         }
12578         vFAIL("Internal urp");
12579                                 /* Supposed to be caught earlier. */
12580         break;
12581     case '?':
12582     case '+':
12583     case '*':
12584         RExC_parse++;
12585         vFAIL("Quantifier follows nothing");
12586         break;
12587     case '\\':
12588         /* Special Escapes
12589
12590            This switch handles escape sequences that resolve to some kind
12591            of special regop and not to literal text. Escape sequnces that
12592            resolve to literal text are handled below in the switch marked
12593            "Literal Escapes".
12594
12595            Every entry in this switch *must* have a corresponding entry
12596            in the literal escape switch. However, the opposite is not
12597            required, as the default for this switch is to jump to the
12598            literal text handling code.
12599         */
12600         RExC_parse++;
12601         switch ((U8)*RExC_parse) {
12602         /* Special Escapes */
12603         case 'A':
12604             RExC_seen_zerolen++;
12605             ret = reg_node(pRExC_state, SBOL);
12606             /* SBOL is shared with /^/ so we set the flags so we can tell
12607              * /\A/ from /^/ in split. We check ret because first pass we
12608              * have no regop struct to set the flags on. */
12609             if (PASS2)
12610                 ret->flags = 1;
12611             *flagp |= SIMPLE;
12612             goto finish_meta_pat;
12613         case 'G':
12614             ret = reg_node(pRExC_state, GPOS);
12615             RExC_seen |= REG_GPOS_SEEN;
12616             *flagp |= SIMPLE;
12617             goto finish_meta_pat;
12618         case 'K':
12619             RExC_seen_zerolen++;
12620             ret = reg_node(pRExC_state, KEEPS);
12621             *flagp |= SIMPLE;
12622             /* XXX:dmq : disabling in-place substitution seems to
12623              * be necessary here to avoid cases of memory corruption, as
12624              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
12625              */
12626             RExC_seen |= REG_LOOKBEHIND_SEEN;
12627             goto finish_meta_pat;
12628         case 'Z':
12629             ret = reg_node(pRExC_state, SEOL);
12630             *flagp |= SIMPLE;
12631             RExC_seen_zerolen++;                /* Do not optimize RE away */
12632             goto finish_meta_pat;
12633         case 'z':
12634             ret = reg_node(pRExC_state, EOS);
12635             *flagp |= SIMPLE;
12636             RExC_seen_zerolen++;                /* Do not optimize RE away */
12637             goto finish_meta_pat;
12638         case 'C':
12639             vFAIL("\\C no longer supported");
12640         case 'X':
12641             ret = reg_node(pRExC_state, CLUMP);
12642             *flagp |= HASWIDTH;
12643             goto finish_meta_pat;
12644
12645         case 'W':
12646             invert = 1;
12647             /* FALLTHROUGH */
12648         case 'w':
12649             arg = ANYOF_WORDCHAR;
12650             goto join_posix;
12651
12652         case 'B':
12653             invert = 1;
12654             /* FALLTHROUGH */
12655         case 'b':
12656           {
12657             regex_charset charset = get_regex_charset(RExC_flags);
12658
12659             RExC_seen_zerolen++;
12660             RExC_seen |= REG_LOOKBEHIND_SEEN;
12661             op = BOUND + charset;
12662
12663             if (op == BOUNDL) {
12664                 RExC_contains_locale = 1;
12665             }
12666
12667             ret = reg_node(pRExC_state, op);
12668             *flagp |= SIMPLE;
12669             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
12670                 FLAGS(ret) = TRADITIONAL_BOUND;
12671                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
12672                     OP(ret) = BOUNDA;
12673                 }
12674             }
12675             else {
12676                 STRLEN length;
12677                 char name = *RExC_parse;
12678                 char * endbrace;
12679                 RExC_parse += 2;
12680                 endbrace = strchr(RExC_parse, '}');
12681
12682                 if (! endbrace) {
12683                     vFAIL2("Missing right brace on \\%c{}", name);
12684                 }
12685                 /* XXX Need to decide whether to take spaces or not.  Should be
12686                  * consistent with \p{}, but that currently is SPACE, which
12687                  * means vertical too, which seems wrong
12688                  * while (isBLANK(*RExC_parse)) {
12689                     RExC_parse++;
12690                 }*/
12691                 if (endbrace == RExC_parse) {
12692                     RExC_parse++;  /* After the '}' */
12693                     vFAIL2("Empty \\%c{}", name);
12694                 }
12695                 length = endbrace - RExC_parse;
12696                 /*while (isBLANK(*(RExC_parse + length - 1))) {
12697                     length--;
12698                 }*/
12699                 switch (*RExC_parse) {
12700                     case 'g':
12701                         if (length != 1
12702                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
12703                         {
12704                             goto bad_bound_type;
12705                         }
12706                         FLAGS(ret) = GCB_BOUND;
12707                         break;
12708                     case 'l':
12709                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12710                             goto bad_bound_type;
12711                         }
12712                         FLAGS(ret) = LB_BOUND;
12713                         break;
12714                     case 's':
12715                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12716                             goto bad_bound_type;
12717                         }
12718                         FLAGS(ret) = SB_BOUND;
12719                         break;
12720                     case 'w':
12721                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12722                             goto bad_bound_type;
12723                         }
12724                         FLAGS(ret) = WB_BOUND;
12725                         break;
12726                     default:
12727                       bad_bound_type:
12728                         RExC_parse = endbrace;
12729                         vFAIL2utf8f(
12730                             "'%" UTF8f "' is an unknown bound type",
12731                             UTF8fARG(UTF, length, endbrace - length));
12732                         NOT_REACHED; /*NOTREACHED*/
12733                 }
12734                 RExC_parse = endbrace;
12735                 REQUIRE_UNI_RULES(flagp, NULL);
12736
12737                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
12738                     OP(ret) = BOUNDU;
12739                     length += 4;
12740
12741                     /* Don't have to worry about UTF-8, in this message because
12742                      * to get here the contents of the \b must be ASCII */
12743                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
12744                               "Using /u for '%.*s' instead of /%s",
12745                               (unsigned) length,
12746                               endbrace - length + 1,
12747                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
12748                               ? ASCII_RESTRICT_PAT_MODS
12749                               : ASCII_MORE_RESTRICT_PAT_MODS);
12750                 }
12751             }
12752
12753             if (PASS2 && invert) {
12754                 OP(ret) += NBOUND - BOUND;
12755             }
12756             goto finish_meta_pat;
12757           }
12758
12759         case 'D':
12760             invert = 1;
12761             /* FALLTHROUGH */
12762         case 'd':
12763             arg = ANYOF_DIGIT;
12764             if (! DEPENDS_SEMANTICS) {
12765                 goto join_posix;
12766             }
12767
12768             /* \d doesn't have any matches in the upper Latin1 range, hence /d
12769              * is equivalent to /u.  Changing to /u saves some branches at
12770              * runtime */
12771             op = POSIXU;
12772             goto join_posix_op_known;
12773
12774         case 'R':
12775             ret = reg_node(pRExC_state, LNBREAK);
12776             *flagp |= HASWIDTH|SIMPLE;
12777             goto finish_meta_pat;
12778
12779         case 'H':
12780             invert = 1;
12781             /* FALLTHROUGH */
12782         case 'h':
12783             arg = ANYOF_BLANK;
12784             op = POSIXU;
12785             goto join_posix_op_known;
12786
12787         case 'V':
12788             invert = 1;
12789             /* FALLTHROUGH */
12790         case 'v':
12791             arg = ANYOF_VERTWS;
12792             op = POSIXU;
12793             goto join_posix_op_known;
12794
12795         case 'S':
12796             invert = 1;
12797             /* FALLTHROUGH */
12798         case 's':
12799             arg = ANYOF_SPACE;
12800
12801           join_posix:
12802
12803             op = POSIXD + get_regex_charset(RExC_flags);
12804             if (op > POSIXA) {  /* /aa is same as /a */
12805                 op = POSIXA;
12806             }
12807             else if (op == POSIXL) {
12808                 RExC_contains_locale = 1;
12809             }
12810
12811           join_posix_op_known:
12812
12813             if (invert) {
12814                 op += NPOSIXD - POSIXD;
12815             }
12816
12817             ret = reg_node(pRExC_state, op);
12818             if (! SIZE_ONLY) {
12819                 FLAGS(ret) = namedclass_to_classnum(arg);
12820             }
12821
12822             *flagp |= HASWIDTH|SIMPLE;
12823             /* FALLTHROUGH */
12824
12825           finish_meta_pat:
12826             nextchar(pRExC_state);
12827             Set_Node_Length(ret, 2); /* MJD */
12828             break;
12829         case 'p':
12830         case 'P':
12831             RExC_parse--;
12832
12833             ret = regclass(pRExC_state, flagp,depth+1,
12834                            TRUE, /* means just parse this element */
12835                            FALSE, /* don't allow multi-char folds */
12836                            FALSE, /* don't silence non-portable warnings.  It
12837                                      would be a bug if these returned
12838                                      non-portables */
12839                            (bool) RExC_strict,
12840                            TRUE, /* Allow an optimized regnode result */
12841                            NULL,
12842                            NULL);
12843             if (*flagp & RESTART_PASS1)
12844                 return NULL;
12845             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
12846              * multi-char folds are allowed.  */
12847             if (!ret)
12848                 FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12849                       (UV) *flagp);
12850
12851             RExC_parse--;
12852
12853             Set_Node_Offset(ret, parse_start);
12854             Set_Node_Cur_Length(ret, parse_start - 2);
12855             nextchar(pRExC_state);
12856             break;
12857         case 'N':
12858             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12859              * \N{...} evaluates to a sequence of more than one code points).
12860              * The function call below returns a regnode, which is our result.
12861              * The parameters cause it to fail if the \N{} evaluates to a
12862              * single code point; we handle those like any other literal.  The
12863              * reason that the multicharacter case is handled here and not as
12864              * part of the EXACtish code is because of quantifiers.  In
12865              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12866              * this way makes that Just Happen. dmq.
12867              * join_exact() will join this up with adjacent EXACTish nodes
12868              * later on, if appropriate. */
12869             ++RExC_parse;
12870             if (grok_bslash_N(pRExC_state,
12871                               &ret,     /* Want a regnode returned */
12872                               NULL,     /* Fail if evaluates to a single code
12873                                            point */
12874                               NULL,     /* Don't need a count of how many code
12875                                            points */
12876                               flagp,
12877                               RExC_strict,
12878                               depth)
12879             ) {
12880                 break;
12881             }
12882
12883             if (*flagp & RESTART_PASS1)
12884                 return NULL;
12885
12886             /* Here, evaluates to a single code point.  Go get that */
12887             RExC_parse = parse_start;
12888             goto defchar;
12889
12890         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12891       parse_named_seq:
12892         {
12893             char ch;
12894             if (   RExC_parse >= RExC_end - 1
12895                 || ((   ch = RExC_parse[1]) != '<'
12896                                       && ch != '\''
12897                                       && ch != '{'))
12898             {
12899                 RExC_parse++;
12900                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12901                 vFAIL2("Sequence %.2s... not terminated",parse_start);
12902             } else {
12903                 RExC_parse += 2;
12904                 ret = handle_named_backref(pRExC_state,
12905                                            flagp,
12906                                            parse_start,
12907                                            (ch == '<')
12908                                            ? '>'
12909                                            : (ch == '{')
12910                                              ? '}'
12911                                              : '\'');
12912             }
12913             break;
12914         }
12915         case 'g':
12916         case '1': case '2': case '3': case '4':
12917         case '5': case '6': case '7': case '8': case '9':
12918             {
12919                 I32 num;
12920                 bool hasbrace = 0;
12921
12922                 if (*RExC_parse == 'g') {
12923                     bool isrel = 0;
12924
12925                     RExC_parse++;
12926                     if (*RExC_parse == '{') {
12927                         RExC_parse++;
12928                         hasbrace = 1;
12929                     }
12930                     if (*RExC_parse == '-') {
12931                         RExC_parse++;
12932                         isrel = 1;
12933                     }
12934                     if (hasbrace && !isDIGIT(*RExC_parse)) {
12935                         if (isrel) RExC_parse--;
12936                         RExC_parse -= 2;
12937                         goto parse_named_seq;
12938                     }
12939
12940                     if (RExC_parse >= RExC_end) {
12941                         goto unterminated_g;
12942                     }
12943                     num = S_backref_value(RExC_parse);
12944                     if (num == 0)
12945                         vFAIL("Reference to invalid group 0");
12946                     else if (num == I32_MAX) {
12947                          if (isDIGIT(*RExC_parse))
12948                             vFAIL("Reference to nonexistent group");
12949                         else
12950                           unterminated_g:
12951                             vFAIL("Unterminated \\g... pattern");
12952                     }
12953
12954                     if (isrel) {
12955                         num = RExC_npar - num;
12956                         if (num < 1)
12957                             vFAIL("Reference to nonexistent or unclosed group");
12958                     }
12959                 }
12960                 else {
12961                     num = S_backref_value(RExC_parse);
12962                     /* bare \NNN might be backref or octal - if it is larger
12963                      * than or equal RExC_npar then it is assumed to be an
12964                      * octal escape. Note RExC_npar is +1 from the actual
12965                      * number of parens. */
12966                     /* Note we do NOT check if num == I32_MAX here, as that is
12967                      * handled by the RExC_npar check */
12968
12969                     if (
12970                         /* any numeric escape < 10 is always a backref */
12971                         num > 9
12972                         /* any numeric escape < RExC_npar is a backref */
12973                         && num >= RExC_npar
12974                         /* cannot be an octal escape if it starts with 8 */
12975                         && *RExC_parse != '8'
12976                         /* cannot be an octal escape it it starts with 9 */
12977                         && *RExC_parse != '9'
12978                     )
12979                     {
12980                         /* Probably not a backref, instead likely to be an
12981                          * octal character escape, e.g. \35 or \777.
12982                          * The above logic should make it obvious why using
12983                          * octal escapes in patterns is problematic. - Yves */
12984                         RExC_parse = parse_start;
12985                         goto defchar;
12986                     }
12987                 }
12988
12989                 /* At this point RExC_parse points at a numeric escape like
12990                  * \12 or \88 or something similar, which we should NOT treat
12991                  * as an octal escape. It may or may not be a valid backref
12992                  * escape. For instance \88888888 is unlikely to be a valid
12993                  * backref. */
12994                 while (isDIGIT(*RExC_parse))
12995                     RExC_parse++;
12996                 if (hasbrace) {
12997                     if (*RExC_parse != '}')
12998                         vFAIL("Unterminated \\g{...} pattern");
12999                     RExC_parse++;
13000                 }
13001                 if (!SIZE_ONLY) {
13002                     if (num > (I32)RExC_rx->nparens)
13003                         vFAIL("Reference to nonexistent group");
13004                 }
13005                 RExC_sawback = 1;
13006                 ret = reganode(pRExC_state,
13007                                ((! FOLD)
13008                                  ? REF
13009                                  : (ASCII_FOLD_RESTRICTED)
13010                                    ? REFFA
13011                                    : (AT_LEAST_UNI_SEMANTICS)
13012                                      ? REFFU
13013                                      : (LOC)
13014                                        ? REFFL
13015                                        : REFF),
13016                                 num);
13017                 *flagp |= HASWIDTH;
13018
13019                 /* override incorrect value set in reganode MJD */
13020                 Set_Node_Offset(ret, parse_start);
13021                 Set_Node_Cur_Length(ret, parse_start-1);
13022                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13023                                         FALSE /* Don't force to /x */ );
13024             }
13025             break;
13026         case '\0':
13027             if (RExC_parse >= RExC_end)
13028                 FAIL("Trailing \\");
13029             /* FALLTHROUGH */
13030         default:
13031             /* Do not generate "unrecognized" warnings here, we fall
13032                back into the quick-grab loop below */
13033             RExC_parse = parse_start;
13034             goto defchar;
13035         } /* end of switch on a \foo sequence */
13036         break;
13037
13038     case '#':
13039
13040         /* '#' comments should have been spaced over before this function was
13041          * called */
13042         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13043         /*
13044         if (RExC_flags & RXf_PMf_EXTENDED) {
13045             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13046             if (RExC_parse < RExC_end)
13047                 goto tryagain;
13048         }
13049         */
13050
13051         /* FALLTHROUGH */
13052
13053     default:
13054           defchar: {
13055
13056             /* Here, we have determined that the next thing is probably a
13057              * literal character.  RExC_parse points to the first byte of its
13058              * definition.  (It still may be an escape sequence that evaluates
13059              * to a single character) */
13060
13061             STRLEN len = 0;
13062             UV ender = 0;
13063             char *p;
13064             char *s;
13065 #define MAX_NODE_STRING_SIZE 127
13066             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
13067             char *s0;
13068             U8 upper_parse = MAX_NODE_STRING_SIZE;
13069             U8 node_type = compute_EXACTish(pRExC_state);
13070             bool next_is_quantifier;
13071             char * oldp = NULL;
13072
13073             /* We can convert EXACTF nodes to EXACTFU if they contain only
13074              * characters that match identically regardless of the target
13075              * string's UTF8ness.  The reason to do this is that EXACTF is not
13076              * trie-able, EXACTFU is.
13077              *
13078              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13079              * contain only above-Latin1 characters (hence must be in UTF8),
13080              * which don't participate in folds with Latin1-range characters,
13081              * as the latter's folds aren't known until runtime.  (We don't
13082              * need to figure this out until pass 2) */
13083             bool maybe_exactfu = PASS2
13084                                && (node_type == EXACTF || node_type == EXACTFL);
13085
13086             /* If a folding node contains only code points that don't
13087              * participate in folds, it can be changed into an EXACT node,
13088              * which allows the optimizer more things to look for */
13089             bool maybe_exact;
13090
13091             ret = reg_node(pRExC_state, node_type);
13092
13093             /* In pass1, folded, we use a temporary buffer instead of the
13094              * actual node, as the node doesn't exist yet */
13095             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
13096
13097             s0 = s;
13098
13099           reparse:
13100
13101             /* We look for the EXACTFish to EXACT node optimizaton only if
13102              * folding.  (And we don't need to figure this out until pass 2).
13103              * XXX It might actually make sense to split the node into portions
13104              * that are exact and ones that aren't, so that we could later use
13105              * the exact ones to find the longest fixed and floating strings.
13106              * One would want to join them back into a larger node.  One could
13107              * use a pseudo regnode like 'EXACT_ORIG_FOLD' */
13108             maybe_exact = FOLD && PASS2;
13109
13110             /* XXX The node can hold up to 255 bytes, yet this only goes to
13111              * 127.  I (khw) do not know why.  Keeping it somewhat less than
13112              * 255 allows us to not have to worry about overflow due to
13113              * converting to utf8 and fold expansion, but that value is
13114              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
13115              * split up by this limit into a single one using the real max of
13116              * 255.  Even at 127, this breaks under rare circumstances.  If
13117              * folding, we do not want to split a node at a character that is a
13118              * non-final in a multi-char fold, as an input string could just
13119              * happen to want to match across the node boundary.  The join
13120              * would solve that problem if the join actually happens.  But a
13121              * series of more than two nodes in a row each of 127 would cause
13122              * the first join to succeed to get to 254, but then there wouldn't
13123              * be room for the next one, which could at be one of those split
13124              * multi-char folds.  I don't know of any fool-proof solution.  One
13125              * could back off to end with only a code point that isn't such a
13126              * non-final, but it is possible for there not to be any in the
13127              * entire node. */
13128
13129             assert(   ! UTF     /* Is at the beginning of a character */
13130                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13131                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13132
13133             /* Here, we have a literal character.  Find the maximal string of
13134              * them in the input that we can fit into a single EXACTish node.
13135              * We quit at the first non-literal or when the node gets full */
13136             for (p = RExC_parse;
13137                  len < upper_parse && p < RExC_end;
13138                  len++)
13139             {
13140                 oldp = p;
13141
13142                 /* White space has already been ignored */
13143                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13144                        || ! is_PATWS_safe((p), RExC_end, UTF));
13145
13146                 switch ((U8)*p) {
13147                 case '^':
13148                 case '$':
13149                 case '.':
13150                 case '[':
13151                 case '(':
13152                 case ')':
13153                 case '|':
13154                     goto loopdone;
13155                 case '\\':
13156                     /* Literal Escapes Switch
13157
13158                        This switch is meant to handle escape sequences that
13159                        resolve to a literal character.
13160
13161                        Every escape sequence that represents something
13162                        else, like an assertion or a char class, is handled
13163                        in the switch marked 'Special Escapes' above in this
13164                        routine, but also has an entry here as anything that
13165                        isn't explicitly mentioned here will be treated as
13166                        an unescaped equivalent literal.
13167                     */
13168
13169                     switch ((U8)*++p) {
13170                     /* These are all the special escapes. */
13171                     case 'A':             /* Start assertion */
13172                     case 'b': case 'B':   /* Word-boundary assertion*/
13173                     case 'C':             /* Single char !DANGEROUS! */
13174                     case 'd': case 'D':   /* digit class */
13175                     case 'g': case 'G':   /* generic-backref, pos assertion */
13176                     case 'h': case 'H':   /* HORIZWS */
13177                     case 'k': case 'K':   /* named backref, keep marker */
13178                     case 'p': case 'P':   /* Unicode property */
13179                               case 'R':   /* LNBREAK */
13180                     case 's': case 'S':   /* space class */
13181                     case 'v': case 'V':   /* VERTWS */
13182                     case 'w': case 'W':   /* word class */
13183                     case 'X':             /* eXtended Unicode "combining
13184                                              character sequence" */
13185                     case 'z': case 'Z':   /* End of line/string assertion */
13186                         --p;
13187                         goto loopdone;
13188
13189                     /* Anything after here is an escape that resolves to a
13190                        literal. (Except digits, which may or may not)
13191                      */
13192                     case 'n':
13193                         ender = '\n';
13194                         p++;
13195                         break;
13196                     case 'N': /* Handle a single-code point named character. */
13197                         RExC_parse = p + 1;
13198                         if (! grok_bslash_N(pRExC_state,
13199                                             NULL,   /* Fail if evaluates to
13200                                                        anything other than a
13201                                                        single code point */
13202                                             &ender, /* The returned single code
13203                                                        point */
13204                                             NULL,   /* Don't need a count of
13205                                                        how many code points */
13206                                             flagp,
13207                                             RExC_strict,
13208                                             depth)
13209                         ) {
13210                             if (*flagp & NEED_UTF8)
13211                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13212                             if (*flagp & RESTART_PASS1)
13213                                 return NULL;
13214
13215                             /* Here, it wasn't a single code point.  Go close
13216                              * up this EXACTish node.  The switch() prior to
13217                              * this switch handles the other cases */
13218                             RExC_parse = p = oldp;
13219                             goto loopdone;
13220                         }
13221                         p = RExC_parse;
13222                         if (ender > 0xff) {
13223                             REQUIRE_UTF8(flagp);
13224                         }
13225                         break;
13226                     case 'r':
13227                         ender = '\r';
13228                         p++;
13229                         break;
13230                     case 't':
13231                         ender = '\t';
13232                         p++;
13233                         break;
13234                     case 'f':
13235                         ender = '\f';
13236                         p++;
13237                         break;
13238                     case 'e':
13239                         ender = ESC_NATIVE;
13240                         p++;
13241                         break;
13242                     case 'a':
13243                         ender = '\a';
13244                         p++;
13245                         break;
13246                     case 'o':
13247                         {
13248                             UV result;
13249                             const char* error_msg;
13250
13251                             bool valid = grok_bslash_o(&p,
13252                                                        &result,
13253                                                        &error_msg,
13254                                                        PASS2, /* out warnings */
13255                                                        (bool) RExC_strict,
13256                                                        TRUE, /* Output warnings
13257                                                                 for non-
13258                                                                 portables */
13259                                                        UTF);
13260                             if (! valid) {
13261                                 RExC_parse = p; /* going to die anyway; point
13262                                                    to exact spot of failure */
13263                                 vFAIL(error_msg);
13264                             }
13265                             ender = result;
13266                             if (ender > 0xff) {
13267                                 REQUIRE_UTF8(flagp);
13268                             }
13269                             break;
13270                         }
13271                     case 'x':
13272                         {
13273                             UV result = UV_MAX; /* initialize to erroneous
13274                                                    value */
13275                             const char* error_msg;
13276
13277                             bool valid = grok_bslash_x(&p,
13278                                                        &result,
13279                                                        &error_msg,
13280                                                        PASS2, /* out warnings */
13281                                                        (bool) RExC_strict,
13282                                                        TRUE, /* Silence warnings
13283                                                                 for non-
13284                                                                 portables */
13285                                                        UTF);
13286                             if (! valid) {
13287                                 RExC_parse = p; /* going to die anyway; point
13288                                                    to exact spot of failure */
13289                                 vFAIL(error_msg);
13290                             }
13291                             ender = result;
13292
13293                             if (ender < 0x100) {
13294 #ifdef EBCDIC
13295                                 if (RExC_recode_x_to_native) {
13296                                     ender = LATIN1_TO_NATIVE(ender);
13297                                 }
13298 #endif
13299                             }
13300                             else {
13301                                 REQUIRE_UTF8(flagp);
13302                             }
13303                             break;
13304                         }
13305                     case 'c':
13306                         p++;
13307                         ender = grok_bslash_c(*p++, PASS2);
13308                         break;
13309                     case '8': case '9': /* must be a backreference */
13310                         --p;
13311                         /* we have an escape like \8 which cannot be an octal escape
13312                          * so we exit the loop, and let the outer loop handle this
13313                          * escape which may or may not be a legitimate backref. */
13314                         goto loopdone;
13315                     case '1': case '2': case '3':case '4':
13316                     case '5': case '6': case '7':
13317                         /* When we parse backslash escapes there is ambiguity
13318                          * between backreferences and octal escapes. Any escape
13319                          * from \1 - \9 is a backreference, any multi-digit
13320                          * escape which does not start with 0 and which when
13321                          * evaluated as decimal could refer to an already
13322                          * parsed capture buffer is a back reference. Anything
13323                          * else is octal.
13324                          *
13325                          * Note this implies that \118 could be interpreted as
13326                          * 118 OR as "\11" . "8" depending on whether there
13327                          * were 118 capture buffers defined already in the
13328                          * pattern.  */
13329
13330                         /* NOTE, RExC_npar is 1 more than the actual number of
13331                          * parens we have seen so far, hence the < RExC_npar below. */
13332
13333                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13334                         {  /* Not to be treated as an octal constant, go
13335                                    find backref */
13336                             --p;
13337                             goto loopdone;
13338                         }
13339                         /* FALLTHROUGH */
13340                     case '0':
13341                         {
13342                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13343                             STRLEN numlen = 3;
13344                             ender = grok_oct(p, &numlen, &flags, NULL);
13345                             if (ender > 0xff) {
13346                                 REQUIRE_UTF8(flagp);
13347                             }
13348                             p += numlen;
13349                             if (PASS2   /* like \08, \178 */
13350                                 && numlen < 3
13351                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13352                             {
13353                                 reg_warn_non_literal_string(
13354                                          p + 1,
13355                                          form_short_octal_warning(p, numlen));
13356                             }
13357                         }
13358                         break;
13359                     case '\0':
13360                         if (p >= RExC_end)
13361                             FAIL("Trailing \\");
13362                         /* FALLTHROUGH */
13363                     default:
13364                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13365                             /* Include any left brace following the alpha to emphasize
13366                              * that it could be part of an escape at some point
13367                              * in the future */
13368                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13369                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13370                         }
13371                         goto normal_default;
13372                     } /* End of switch on '\' */
13373                     break;
13374                 case '{':
13375                     /* Currently we don't care if the lbrace is at the start
13376                      * of a construct.  This catches it in the middle of a
13377                      * literal string, or when it's the first thing after
13378                      * something like "\b" */
13379                     if (len || (p > RExC_start && isALPHA_A(*(p -1)))) {
13380                         RExC_parse = p + 1;
13381                         vFAIL("Unescaped left brace in regex is illegal here");
13382                     }
13383                     /*FALLTHROUGH*/
13384                 default:    /* A literal character */
13385                   normal_default:
13386                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13387                         STRLEN numlen;
13388                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13389                                                &numlen, UTF8_ALLOW_DEFAULT);
13390                         p += numlen;
13391                     }
13392                     else
13393                         ender = (U8) *p++;
13394                     break;
13395                 } /* End of switch on the literal */
13396
13397                 /* Here, have looked at the literal character and <ender>
13398                  * contains its ordinal, <p> points to the character after it.
13399                  * We need to check if the next non-ignored thing is a
13400                  * quantifier.  Move <p> to after anything that should be
13401                  * ignored, which, as a side effect, positions <p> for the next
13402                  * loop iteration */
13403                 skip_to_be_ignored_text(pRExC_state, &p,
13404                                         FALSE /* Don't force to /x */ );
13405
13406                 /* If the next thing is a quantifier, it applies to this
13407                  * character only, which means that this character has to be in
13408                  * its own node and can't just be appended to the string in an
13409                  * existing node, so if there are already other characters in
13410                  * the node, close the node with just them, and set up to do
13411                  * this character again next time through, when it will be the
13412                  * only thing in its new node */
13413
13414                 if ((next_is_quantifier = (   LIKELY(p < RExC_end)
13415                                            && UNLIKELY(ISMULT2(p))))
13416                     && LIKELY(len))
13417                 {
13418                     p = oldp;
13419                     goto loopdone;
13420                 }
13421
13422                 /* Ready to add 'ender' to the node */
13423
13424                 if (! FOLD) {  /* The simple case, just append the literal */
13425
13426                     /* In the sizing pass, we need only the size of the
13427                      * character we are appending, hence we can delay getting
13428                      * its representation until PASS2. */
13429                     if (SIZE_ONLY) {
13430                         if (UTF) {
13431                             const STRLEN unilen = UVCHR_SKIP(ender);
13432                             s += unilen;
13433
13434                             /* We have to subtract 1 just below (and again in
13435                              * the corresponding PASS2 code) because the loop
13436                              * increments <len> each time, as all but this path
13437                              * (and one other) through it add a single byte to
13438                              * the EXACTish node.  But these paths would change
13439                              * len to be the correct final value, so cancel out
13440                              * the increment that follows */
13441                             len += unilen - 1;
13442                         }
13443                         else {
13444                             s++;
13445                         }
13446                     } else { /* PASS2 */
13447                       not_fold_common:
13448                         if (UTF) {
13449                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13450                             len += (char *) new_s - s - 1;
13451                             s = (char *) new_s;
13452                         }
13453                         else {
13454                             *(s++) = (char) ender;
13455                         }
13456                     }
13457                 }
13458                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13459
13460                     /* Here are folding under /l, and the code point is
13461                      * problematic.  First, we know we can't simplify things */
13462                     maybe_exact = FALSE;
13463                     maybe_exactfu = FALSE;
13464
13465                     /* A problematic code point in this context means that its
13466                      * fold isn't known until runtime, so we can't fold it now.
13467                      * (The non-problematic code points are the above-Latin1
13468                      * ones that fold to also all above-Latin1.  Their folds
13469                      * don't vary no matter what the locale is.) But here we
13470                      * have characters whose fold depends on the locale.
13471                      * Unlike the non-folding case above, we have to keep track
13472                      * of these in the sizing pass, so that we can make sure we
13473                      * don't split too-long nodes in the middle of a potential
13474                      * multi-char fold.  And unlike the regular fold case
13475                      * handled in the else clauses below, we don't actually
13476                      * fold and don't have special cases to consider.  What we
13477                      * do for both passes is the PASS2 code for non-folding */
13478                     goto not_fold_common;
13479                 }
13480                 else /* A regular FOLD code point */
13481                     if (! (   UTF
13482 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13483    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13484                                       || UNICODE_DOT_DOT_VERSION > 0)
13485                             /* See comments for join_exact() as to why we fold
13486                              * this non-UTF at compile time */
13487                             || (   node_type == EXACTFU
13488                                 && ender == LATIN_SMALL_LETTER_SHARP_S)
13489 #endif
13490                 )) {
13491                     /* Here, are folding and are not UTF-8 encoded; therefore
13492                      * the character must be in the range 0-255, and is not /l
13493                      * (Not /l because we already handled these under /l in
13494                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13495                     if (IS_IN_SOME_FOLD_L1(ender)) {
13496                         maybe_exact = FALSE;
13497
13498                         /* See if the character's fold differs between /d and
13499                          * /u.  This includes the multi-char fold SHARP S to
13500                          * 'ss' */
13501                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13502                             RExC_seen_unfolded_sharp_s = 1;
13503                             maybe_exactfu = FALSE;
13504                         }
13505                         else if (maybe_exactfu
13506                             && (PL_fold[ender] != PL_fold_latin1[ender]
13507 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13508    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13509                                       || UNICODE_DOT_DOT_VERSION > 0)
13510                                 || (   len > 0
13511                                     && isALPHA_FOLD_EQ(ender, 's')
13512                                     && isALPHA_FOLD_EQ(*(s-1), 's'))
13513 #endif
13514                         )) {
13515                             maybe_exactfu = FALSE;
13516                         }
13517                     }
13518
13519                     /* Even when folding, we store just the input character, as
13520                      * we have an array that finds its fold quickly */
13521                     *(s++) = (char) ender;
13522                 }
13523                 else {  /* FOLD, and UTF (or sharp s) */
13524                     /* Unlike the non-fold case, we do actually have to
13525                      * calculate the results here in pass 1.  This is for two
13526                      * reasons, the folded length may be longer than the
13527                      * unfolded, and we have to calculate how many EXACTish
13528                      * nodes it will take; and we may run out of room in a node
13529                      * in the middle of a potential multi-char fold, and have
13530                      * to back off accordingly.  */
13531
13532                     UV folded;
13533                     if (isASCII_uni(ender)) {
13534                         folded = toFOLD(ender);
13535                         *(s)++ = (U8) folded;
13536                     }
13537                     else {
13538                         STRLEN foldlen;
13539
13540                         folded = _to_uni_fold_flags(
13541                                      ender,
13542                                      (U8 *) s,
13543                                      &foldlen,
13544                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
13545                                                         ? FOLD_FLAGS_NOMIX_ASCII
13546                                                         : 0));
13547                         s += foldlen;
13548
13549                         /* The loop increments <len> each time, as all but this
13550                          * path (and one other) through it add a single byte to
13551                          * the EXACTish node.  But this one has changed len to
13552                          * be the correct final value, so subtract one to
13553                          * cancel out the increment that follows */
13554                         len += foldlen - 1;
13555                     }
13556                     /* If this node only contains non-folding code points so
13557                      * far, see if this new one is also non-folding */
13558                     if (maybe_exact) {
13559                         if (folded != ender) {
13560                             maybe_exact = FALSE;
13561                         }
13562                         else {
13563                             /* Here the fold is the original; we have to check
13564                              * further to see if anything folds to it */
13565                             if (_invlist_contains_cp(PL_utf8_foldable,
13566                                                         ender))
13567                             {
13568                                 maybe_exact = FALSE;
13569                             }
13570                         }
13571                     }
13572                     ender = folded;
13573                 }
13574
13575                 if (next_is_quantifier) {
13576
13577                     /* Here, the next input is a quantifier, and to get here,
13578                      * the current character is the only one in the node.
13579                      * Also, here <len> doesn't include the final byte for this
13580                      * character */
13581                     len++;
13582                     goto loopdone;
13583                 }
13584
13585             } /* End of loop through literal characters */
13586
13587             /* Here we have either exhausted the input or ran out of room in
13588              * the node.  (If we encountered a character that can't be in the
13589              * node, transfer is made directly to <loopdone>, and so we
13590              * wouldn't have fallen off the end of the loop.)  In the latter
13591              * case, we artificially have to split the node into two, because
13592              * we just don't have enough space to hold everything.  This
13593              * creates a problem if the final character participates in a
13594              * multi-character fold in the non-final position, as a match that
13595              * should have occurred won't, due to the way nodes are matched,
13596              * and our artificial boundary.  So back off until we find a non-
13597              * problematic character -- one that isn't at the beginning or
13598              * middle of such a fold.  (Either it doesn't participate in any
13599              * folds, or appears only in the final position of all the folds it
13600              * does participate in.)  A better solution with far fewer false
13601              * positives, and that would fill the nodes more completely, would
13602              * be to actually have available all the multi-character folds to
13603              * test against, and to back-off only far enough to be sure that
13604              * this node isn't ending with a partial one.  <upper_parse> is set
13605              * further below (if we need to reparse the node) to include just
13606              * up through that final non-problematic character that this code
13607              * identifies, so when it is set to less than the full node, we can
13608              * skip the rest of this */
13609             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
13610
13611                 const STRLEN full_len = len;
13612
13613                 assert(len >= MAX_NODE_STRING_SIZE);
13614
13615                 /* Here, <s> points to the final byte of the final character.
13616                  * Look backwards through the string until find a non-
13617                  * problematic character */
13618
13619                 if (! UTF) {
13620
13621                     /* This has no multi-char folds to non-UTF characters */
13622                     if (ASCII_FOLD_RESTRICTED) {
13623                         goto loopdone;
13624                     }
13625
13626                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
13627                     len = s - s0 + 1;
13628                 }
13629                 else {
13630                     if (!  PL_NonL1NonFinalFold) {
13631                         PL_NonL1NonFinalFold = _new_invlist_C_array(
13632                                         NonL1_Perl_Non_Final_Folds_invlist);
13633                     }
13634
13635                     /* Point to the first byte of the final character */
13636                     s = (char *) utf8_hop((U8 *) s, -1);
13637
13638                     while (s >= s0) {   /* Search backwards until find
13639                                            non-problematic char */
13640                         if (UTF8_IS_INVARIANT(*s)) {
13641
13642                             /* There are no ascii characters that participate
13643                              * in multi-char folds under /aa.  In EBCDIC, the
13644                              * non-ascii invariants are all control characters,
13645                              * so don't ever participate in any folds. */
13646                             if (ASCII_FOLD_RESTRICTED
13647                                 || ! IS_NON_FINAL_FOLD(*s))
13648                             {
13649                                 break;
13650                             }
13651                         }
13652                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
13653                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
13654                                                                   *s, *(s+1))))
13655                             {
13656                                 break;
13657                             }
13658                         }
13659                         else if (! _invlist_contains_cp(
13660                                         PL_NonL1NonFinalFold,
13661                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
13662                         {
13663                             break;
13664                         }
13665
13666                         /* Here, the current character is problematic in that
13667                          * it does occur in the non-final position of some
13668                          * fold, so try the character before it, but have to
13669                          * special case the very first byte in the string, so
13670                          * we don't read outside the string */
13671                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
13672                     } /* End of loop backwards through the string */
13673
13674                     /* If there were only problematic characters in the string,
13675                      * <s> will point to before s0, in which case the length
13676                      * should be 0, otherwise include the length of the
13677                      * non-problematic character just found */
13678                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
13679                 }
13680
13681                 /* Here, have found the final character, if any, that is
13682                  * non-problematic as far as ending the node without splitting
13683                  * it across a potential multi-char fold.  <len> contains the
13684                  * number of bytes in the node up-to and including that
13685                  * character, or is 0 if there is no such character, meaning
13686                  * the whole node contains only problematic characters.  In
13687                  * this case, give up and just take the node as-is.  We can't
13688                  * do any better */
13689                 if (len == 0) {
13690                     len = full_len;
13691
13692                     /* If the node ends in an 's' we make sure it stays EXACTF,
13693                      * as if it turns into an EXACTFU, it could later get
13694                      * joined with another 's' that would then wrongly match
13695                      * the sharp s */
13696                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
13697                     {
13698                         maybe_exactfu = FALSE;
13699                     }
13700                 } else {
13701
13702                     /* Here, the node does contain some characters that aren't
13703                      * problematic.  If one such is the final character in the
13704                      * node, we are done */
13705                     if (len == full_len) {
13706                         goto loopdone;
13707                     }
13708                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
13709
13710                         /* If the final character is problematic, but the
13711                          * penultimate is not, back-off that last character to
13712                          * later start a new node with it */
13713                         p = oldp;
13714                         goto loopdone;
13715                     }
13716
13717                     /* Here, the final non-problematic character is earlier
13718                      * in the input than the penultimate character.  What we do
13719                      * is reparse from the beginning, going up only as far as
13720                      * this final ok one, thus guaranteeing that the node ends
13721                      * in an acceptable character.  The reason we reparse is
13722                      * that we know how far in the character is, but we don't
13723                      * know how to correlate its position with the input parse.
13724                      * An alternate implementation would be to build that
13725                      * correlation as we go along during the original parse,
13726                      * but that would entail extra work for every node, whereas
13727                      * this code gets executed only when the string is too
13728                      * large for the node, and the final two characters are
13729                      * problematic, an infrequent occurrence.  Yet another
13730                      * possible strategy would be to save the tail of the
13731                      * string, and the next time regatom is called, initialize
13732                      * with that.  The problem with this is that unless you
13733                      * back off one more character, you won't be guaranteed
13734                      * regatom will get called again, unless regbranch,
13735                      * regpiece ... are also changed.  If you do back off that
13736                      * extra character, so that there is input guaranteed to
13737                      * force calling regatom, you can't handle the case where
13738                      * just the first character in the node is acceptable.  I
13739                      * (khw) decided to try this method which doesn't have that
13740                      * pitfall; if performance issues are found, we can do a
13741                      * combination of the current approach plus that one */
13742                     upper_parse = len;
13743                     len = 0;
13744                     s = s0;
13745                     goto reparse;
13746                 }
13747             }   /* End of verifying node ends with an appropriate char */
13748
13749           loopdone:   /* Jumped to when encounters something that shouldn't be
13750                          in the node */
13751
13752             /* I (khw) don't know if you can get here with zero length, but the
13753              * old code handled this situation by creating a zero-length EXACT
13754              * node.  Might as well be NOTHING instead */
13755             if (len == 0) {
13756                 OP(ret) = NOTHING;
13757             }
13758             else {
13759                 if (FOLD) {
13760                     /* If 'maybe_exact' is still set here, means there are no
13761                      * code points in the node that participate in folds;
13762                      * similarly for 'maybe_exactfu' and code points that match
13763                      * differently depending on UTF8ness of the target string
13764                      * (for /u), or depending on locale for /l */
13765                     if (maybe_exact) {
13766                         OP(ret) = (LOC)
13767                                   ? EXACTL
13768                                   : EXACT;
13769                     }
13770                     else if (maybe_exactfu) {
13771                         OP(ret) = (LOC)
13772                                   ? EXACTFLU8
13773                                   : EXACTFU;
13774                     }
13775                 }
13776                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
13777                                            FALSE /* Don't look to see if could
13778                                                     be turned into an EXACT
13779                                                     node, as we have already
13780                                                     computed that */
13781                                           );
13782             }
13783
13784             RExC_parse = p - 1;
13785             Set_Node_Cur_Length(ret, parse_start);
13786             RExC_parse = p;
13787             {
13788                 /* len is STRLEN which is unsigned, need to copy to signed */
13789                 IV iv = len;
13790                 if (iv < 0)
13791                     vFAIL("Internal disaster");
13792             }
13793
13794         } /* End of label 'defchar:' */
13795         break;
13796     } /* End of giant switch on input character */
13797
13798     /* Position parse to next real character */
13799     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13800                                             FALSE /* Don't force to /x */ );
13801     if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
13802         ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here, passed through");
13803     }
13804
13805     return(ret);
13806 }
13807
13808
13809 STATIC void
13810 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
13811 {
13812     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13813      * sets up the bitmap and any flags, removing those code points from the
13814      * inversion list, setting it to NULL should it become completely empty */
13815
13816     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13817     assert(PL_regkind[OP(node)] == ANYOF);
13818
13819     ANYOF_BITMAP_ZERO(node);
13820     if (*invlist_ptr) {
13821
13822         /* This gets set if we actually need to modify things */
13823         bool change_invlist = FALSE;
13824
13825         UV start, end;
13826
13827         /* Start looking through *invlist_ptr */
13828         invlist_iterinit(*invlist_ptr);
13829         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13830             UV high;
13831             int i;
13832
13833             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13834                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13835             }
13836
13837             /* Quit if are above what we should change */
13838             if (start >= NUM_ANYOF_CODE_POINTS) {
13839                 break;
13840             }
13841
13842             change_invlist = TRUE;
13843
13844             /* Set all the bits in the range, up to the max that we are doing */
13845             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13846                    ? end
13847                    : NUM_ANYOF_CODE_POINTS - 1;
13848             for (i = start; i <= (int) high; i++) {
13849                 if (! ANYOF_BITMAP_TEST(node, i)) {
13850                     ANYOF_BITMAP_SET(node, i);
13851                 }
13852             }
13853         }
13854         invlist_iterfinish(*invlist_ptr);
13855
13856         /* Done with loop; remove any code points that are in the bitmap from
13857          * *invlist_ptr; similarly for code points above the bitmap if we have
13858          * a flag to match all of them anyways */
13859         if (change_invlist) {
13860             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13861         }
13862         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13863             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13864         }
13865
13866         /* If have completely emptied it, remove it completely */
13867         if (_invlist_len(*invlist_ptr) == 0) {
13868             SvREFCNT_dec_NN(*invlist_ptr);
13869             *invlist_ptr = NULL;
13870         }
13871     }
13872 }
13873
13874 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
13875    Character classes ([:foo:]) can also be negated ([:^foo:]).
13876    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
13877    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
13878    but trigger failures because they are currently unimplemented. */
13879
13880 #define POSIXCC_DONE(c)   ((c) == ':')
13881 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
13882 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
13883 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
13884
13885 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
13886 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
13887 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
13888
13889 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
13890
13891 /* 'posix_warnings' and 'warn_text' are names of variables in the following
13892  * routine. q.v. */
13893 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
13894         if (posix_warnings) {                                               \
13895             if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
13896             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                          \
13897                                              WARNING_PREFIX                 \
13898                                              text                           \
13899                                              REPORT_LOCATION,               \
13900                                              REPORT_LOCATION_ARGS(p)));     \
13901         }                                                                   \
13902     } STMT_END
13903
13904 STATIC int
13905 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
13906
13907     const char * const s,      /* Where the putative posix class begins.
13908                                   Normally, this is one past the '['.  This
13909                                   parameter exists so it can be somewhere
13910                                   besides RExC_parse. */
13911     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
13912                                   NULL */
13913     AV ** posix_warnings,      /* Where to place any generated warnings, or
13914                                   NULL */
13915     const bool check_only      /* Don't die if error */
13916 )
13917 {
13918     /* This parses what the caller thinks may be one of the three POSIX
13919      * constructs:
13920      *  1) a character class, like [:blank:]
13921      *  2) a collating symbol, like [. .]
13922      *  3) an equivalence class, like [= =]
13923      * In the latter two cases, it croaks if it finds a syntactically legal
13924      * one, as these are not handled by Perl.
13925      *
13926      * The main purpose is to look for a POSIX character class.  It returns:
13927      *  a) the class number
13928      *      if it is a completely syntactically and semantically legal class.
13929      *      'updated_parse_ptr', if not NULL, is set to point to just after the
13930      *      closing ']' of the class
13931      *  b) OOB_NAMEDCLASS
13932      *      if it appears that one of the three POSIX constructs was meant, but
13933      *      its specification was somehow defective.  'updated_parse_ptr', if
13934      *      not NULL, is set to point to the character just after the end
13935      *      character of the class.  See below for handling of warnings.
13936      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
13937      *      if it  doesn't appear that a POSIX construct was intended.
13938      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
13939      *      raised.
13940      *
13941      * In b) there may be errors or warnings generated.  If 'check_only' is
13942      * TRUE, then any errors are discarded.  Warnings are returned to the
13943      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
13944      * instead it is NULL, warnings are suppressed.  This is done in all
13945      * passes.  The reason for this is that the rest of the parsing is heavily
13946      * dependent on whether this routine found a valid posix class or not.  If
13947      * it did, the closing ']' is absorbed as part of the class.  If no class,
13948      * or an invalid one is found, any ']' will be considered the terminator of
13949      * the outer bracketed character class, leading to very different results.
13950      * In particular, a '(?[ ])' construct will likely have a syntax error if
13951      * the class is parsed other than intended, and this will happen in pass1,
13952      * before the warnings would normally be output.  This mechanism allows the
13953      * caller to output those warnings in pass1 just before dieing, giving a
13954      * much better clue as to what is wrong.
13955      *
13956      * The reason for this function, and its complexity is that a bracketed
13957      * character class can contain just about anything.  But it's easy to
13958      * mistype the very specific posix class syntax but yielding a valid
13959      * regular bracketed class, so it silently gets compiled into something
13960      * quite unintended.
13961      *
13962      * The solution adopted here maintains backward compatibility except that
13963      * it adds a warning if it looks like a posix class was intended but
13964      * improperly specified.  The warning is not raised unless what is input
13965      * very closely resembles one of the 14 legal posix classes.  To do this,
13966      * it uses fuzzy parsing.  It calculates how many single-character edits it
13967      * would take to transform what was input into a legal posix class.  Only
13968      * if that number is quite small does it think that the intention was a
13969      * posix class.  Obviously these are heuristics, and there will be cases
13970      * where it errs on one side or another, and they can be tweaked as
13971      * experience informs.
13972      *
13973      * The syntax for a legal posix class is:
13974      *
13975      * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
13976      *
13977      * What this routine considers syntactically to be an intended posix class
13978      * is this (the comments indicate some restrictions that the pattern
13979      * doesn't show):
13980      *
13981      *  qr/(?x: \[?                         # The left bracket, possibly
13982      *                                      # omitted
13983      *          \h*                         # possibly followed by blanks
13984      *          (?: \^ \h* )?               # possibly a misplaced caret
13985      *          [:;]?                       # The opening class character,
13986      *                                      # possibly omitted.  A typo
13987      *                                      # semi-colon can also be used.
13988      *          \h*
13989      *          \^?                         # possibly a correctly placed
13990      *                                      # caret, but not if there was also
13991      *                                      # a misplaced one
13992      *          \h*
13993      *          .{3,15}                     # The class name.  If there are
13994      *                                      # deviations from the legal syntax,
13995      *                                      # its edit distance must be close
13996      *                                      # to a real class name in order
13997      *                                      # for it to be considered to be
13998      *                                      # an intended posix class.
13999      *          \h*
14000      *          [:punct:]?                  # The closing class character,
14001      *                                      # possibly omitted.  If not a colon
14002      *                                      # nor semi colon, the class name
14003      *                                      # must be even closer to a valid
14004      *                                      # one
14005      *          \h*
14006      *          \]?                         # The right bracket, possibly
14007      *                                      # omitted.
14008      *     )/
14009      *
14010      * In the above, \h must be ASCII-only.
14011      *
14012      * These are heuristics, and can be tweaked as field experience dictates.
14013      * There will be cases when someone didn't intend to specify a posix class
14014      * that this warns as being so.  The goal is to minimize these, while
14015      * maximizing the catching of things intended to be a posix class that
14016      * aren't parsed as such.
14017      */
14018
14019     const char* p             = s;
14020     const char * const e      = RExC_end;
14021     unsigned complement       = 0;      /* If to complement the class */
14022     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
14023     bool has_opening_bracket  = FALSE;
14024     bool has_opening_colon    = FALSE;
14025     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
14026                                                    valid class */
14027     const char * possible_end = NULL;   /* used for a 2nd parse pass */
14028     const char* name_start;             /* ptr to class name first char */
14029
14030     /* If the number of single-character typos the input name is away from a
14031      * legal name is no more than this number, it is considered to have meant
14032      * the legal name */
14033     int max_distance          = 2;
14034
14035     /* to store the name.  The size determines the maximum length before we
14036      * decide that no posix class was intended.  Should be at least
14037      * sizeof("alphanumeric") */
14038     UV input_text[15];
14039
14040     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
14041
14042     if (posix_warnings && RExC_warn_text)
14043         av_clear(RExC_warn_text);
14044
14045     if (p >= e) {
14046         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14047     }
14048
14049     if (*(p - 1) != '[') {
14050         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
14051         found_problem = TRUE;
14052     }
14053     else {
14054         has_opening_bracket = TRUE;
14055     }
14056
14057     /* They could be confused and think you can put spaces between the
14058      * components */
14059     if (isBLANK(*p)) {
14060         found_problem = TRUE;
14061
14062         do {
14063             p++;
14064         } while (p < e && isBLANK(*p));
14065
14066         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14067     }
14068
14069     /* For [. .] and [= =].  These are quite different internally from [: :],
14070      * so they are handled separately.  */
14071     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
14072                                             and 1 for at least one char in it
14073                                           */
14074     {
14075         const char open_char  = *p;
14076         const char * temp_ptr = p + 1;
14077
14078         /* These two constructs are not handled by perl, and if we find a
14079          * syntactically valid one, we croak.  khw, who wrote this code, finds
14080          * this explanation of them very unclear:
14081          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
14082          * And searching the rest of the internet wasn't very helpful either.
14083          * It looks like just about any byte can be in these constructs,
14084          * depending on the locale.  But unless the pattern is being compiled
14085          * under /l, which is very rare, Perl runs under the C or POSIX locale.
14086          * In that case, it looks like [= =] isn't allowed at all, and that
14087          * [. .] could be any single code point, but for longer strings the
14088          * constituent characters would have to be the ASCII alphabetics plus
14089          * the minus-hyphen.  Any sensible locale definition would limit itself
14090          * to these.  And any portable one definitely should.  Trying to parse
14091          * the general case is a nightmare (see [perl #127604]).  So, this code
14092          * looks only for interiors of these constructs that match:
14093          *      qr/.|[-\w]{2,}/
14094          * Using \w relaxes the apparent rules a little, without adding much
14095          * danger of mistaking something else for one of these constructs.
14096          *
14097          * [. .] in some implementations described on the internet is usable to
14098          * escape a character that otherwise is special in bracketed character
14099          * classes.  For example [.].] means a literal right bracket instead of
14100          * the ending of the class
14101          *
14102          * [= =] can legitimately contain a [. .] construct, but we don't
14103          * handle this case, as that [. .] construct will later get parsed
14104          * itself and croak then.  And [= =] is checked for even when not under
14105          * /l, as Perl has long done so.
14106          *
14107          * The code below relies on there being a trailing NUL, so it doesn't
14108          * have to keep checking if the parse ptr < e.
14109          */
14110         if (temp_ptr[1] == open_char) {
14111             temp_ptr++;
14112         }
14113         else while (    temp_ptr < e
14114                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
14115         {
14116             temp_ptr++;
14117         }
14118
14119         if (*temp_ptr == open_char) {
14120             temp_ptr++;
14121             if (*temp_ptr == ']') {
14122                 temp_ptr++;
14123                 if (! found_problem && ! check_only) {
14124                     RExC_parse = (char *) temp_ptr;
14125                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
14126                             "extensions", open_char, open_char);
14127                 }
14128
14129                 /* Here, the syntax wasn't completely valid, or else the call
14130                  * is to check-only */
14131                 if (updated_parse_ptr) {
14132                     *updated_parse_ptr = (char *) temp_ptr;
14133                 }
14134
14135                 return OOB_NAMEDCLASS;
14136             }
14137         }
14138
14139         /* If we find something that started out to look like one of these
14140          * constructs, but isn't, we continue below so that it can be checked
14141          * for being a class name with a typo of '.' or '=' instead of a colon.
14142          * */
14143     }
14144
14145     /* Here, we think there is a possibility that a [: :] class was meant, and
14146      * we have the first real character.  It could be they think the '^' comes
14147      * first */
14148     if (*p == '^') {
14149         found_problem = TRUE;
14150         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
14151         complement = 1;
14152         p++;
14153
14154         if (isBLANK(*p)) {
14155             found_problem = TRUE;
14156
14157             do {
14158                 p++;
14159             } while (p < e && isBLANK(*p));
14160
14161             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14162         }
14163     }
14164
14165     /* But the first character should be a colon, which they could have easily
14166      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
14167      * distinguish from a colon, so treat that as a colon).  */
14168     if (*p == ':') {
14169         p++;
14170         has_opening_colon = TRUE;
14171     }
14172     else if (*p == ';') {
14173         found_problem = TRUE;
14174         p++;
14175         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14176         has_opening_colon = TRUE;
14177     }
14178     else {
14179         found_problem = TRUE;
14180         ADD_POSIX_WARNING(p, "there must be a starting ':'");
14181
14182         /* Consider an initial punctuation (not one of the recognized ones) to
14183          * be a left terminator */
14184         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
14185             p++;
14186         }
14187     }
14188
14189     /* They may think that you can put spaces between the components */
14190     if (isBLANK(*p)) {
14191         found_problem = TRUE;
14192
14193         do {
14194             p++;
14195         } while (p < e && isBLANK(*p));
14196
14197         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14198     }
14199
14200     if (*p == '^') {
14201
14202         /* We consider something like [^:^alnum:]] to not have been intended to
14203          * be a posix class, but XXX maybe we should */
14204         if (complement) {
14205             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14206         }
14207
14208         complement = 1;
14209         p++;
14210     }
14211
14212     /* Again, they may think that you can put spaces between the components */
14213     if (isBLANK(*p)) {
14214         found_problem = TRUE;
14215
14216         do {
14217             p++;
14218         } while (p < e && isBLANK(*p));
14219
14220         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14221     }
14222
14223     if (*p == ']') {
14224
14225         /* XXX This ']' may be a typo, and something else was meant.  But
14226          * treating it as such creates enough complications, that that
14227          * possibility isn't currently considered here.  So we assume that the
14228          * ']' is what is intended, and if we've already found an initial '[',
14229          * this leaves this construct looking like [:] or [:^], which almost
14230          * certainly weren't intended to be posix classes */
14231         if (has_opening_bracket) {
14232             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14233         }
14234
14235         /* But this function can be called when we parse the colon for
14236          * something like qr/[alpha:]]/, so we back up to look for the
14237          * beginning */
14238         p--;
14239
14240         if (*p == ';') {
14241             found_problem = TRUE;
14242             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14243         }
14244         else if (*p != ':') {
14245
14246             /* XXX We are currently very restrictive here, so this code doesn't
14247              * consider the possibility that, say, /[alpha.]]/ was intended to
14248              * be a posix class. */
14249             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14250         }
14251
14252         /* Here we have something like 'foo:]'.  There was no initial colon,
14253          * and we back up over 'foo.  XXX Unlike the going forward case, we
14254          * don't handle typos of non-word chars in the middle */
14255         has_opening_colon = FALSE;
14256         p--;
14257
14258         while (p > RExC_start && isWORDCHAR(*p)) {
14259             p--;
14260         }
14261         p++;
14262
14263         /* Here, we have positioned ourselves to where we think the first
14264          * character in the potential class is */
14265     }
14266
14267     /* Now the interior really starts.  There are certain key characters that
14268      * can end the interior, or these could just be typos.  To catch both
14269      * cases, we may have to do two passes.  In the first pass, we keep on
14270      * going unless we come to a sequence that matches
14271      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14272      * This means it takes a sequence to end the pass, so two typos in a row if
14273      * that wasn't what was intended.  If the class is perfectly formed, just
14274      * this one pass is needed.  We also stop if there are too many characters
14275      * being accumulated, but this number is deliberately set higher than any
14276      * real class.  It is set high enough so that someone who thinks that
14277      * 'alphanumeric' is a correct name would get warned that it wasn't.
14278      * While doing the pass, we keep track of where the key characters were in
14279      * it.  If we don't find an end to the class, and one of the key characters
14280      * was found, we redo the pass, but stop when we get to that character.
14281      * Thus the key character was considered a typo in the first pass, but a
14282      * terminator in the second.  If two key characters are found, we stop at
14283      * the second one in the first pass.  Again this can miss two typos, but
14284      * catches a single one
14285      *
14286      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14287      * point to the first key character.  For the second pass, it starts as -1.
14288      * */
14289
14290     name_start = p;
14291   parse_name:
14292     {
14293         bool has_blank               = FALSE;
14294         bool has_upper               = FALSE;
14295         bool has_terminating_colon   = FALSE;
14296         bool has_terminating_bracket = FALSE;
14297         bool has_semi_colon          = FALSE;
14298         unsigned int name_len        = 0;
14299         int punct_count              = 0;
14300
14301         while (p < e) {
14302
14303             /* Squeeze out blanks when looking up the class name below */
14304             if (isBLANK(*p) ) {
14305                 has_blank = TRUE;
14306                 found_problem = TRUE;
14307                 p++;
14308                 continue;
14309             }
14310
14311             /* The name will end with a punctuation */
14312             if (isPUNCT(*p)) {
14313                 const char * peek = p + 1;
14314
14315                 /* Treat any non-']' punctuation followed by a ']' (possibly
14316                  * with intervening blanks) as trying to terminate the class.
14317                  * ']]' is very likely to mean a class was intended (but
14318                  * missing the colon), but the warning message that gets
14319                  * generated shows the error position better if we exit the
14320                  * loop at the bottom (eventually), so skip it here. */
14321                 if (*p != ']') {
14322                     if (peek < e && isBLANK(*peek)) {
14323                         has_blank = TRUE;
14324                         found_problem = TRUE;
14325                         do {
14326                             peek++;
14327                         } while (peek < e && isBLANK(*peek));
14328                     }
14329
14330                     if (peek < e && *peek == ']') {
14331                         has_terminating_bracket = TRUE;
14332                         if (*p == ':') {
14333                             has_terminating_colon = TRUE;
14334                         }
14335                         else if (*p == ';') {
14336                             has_semi_colon = TRUE;
14337                             has_terminating_colon = TRUE;
14338                         }
14339                         else {
14340                             found_problem = TRUE;
14341                         }
14342                         p = peek + 1;
14343                         goto try_posix;
14344                     }
14345                 }
14346
14347                 /* Here we have punctuation we thought didn't end the class.
14348                  * Keep track of the position of the key characters that are
14349                  * more likely to have been class-enders */
14350                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14351
14352                     /* Allow just one such possible class-ender not actually
14353                      * ending the class. */
14354                     if (possible_end) {
14355                         break;
14356                     }
14357                     possible_end = p;
14358                 }
14359
14360                 /* If we have too many punctuation characters, no use in
14361                  * keeping going */
14362                 if (++punct_count > max_distance) {
14363                     break;
14364                 }
14365
14366                 /* Treat the punctuation as a typo. */
14367                 input_text[name_len++] = *p;
14368                 p++;
14369             }
14370             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14371                 input_text[name_len++] = toLOWER(*p);
14372                 has_upper = TRUE;
14373                 found_problem = TRUE;
14374                 p++;
14375             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14376                 input_text[name_len++] = *p;
14377                 p++;
14378             }
14379             else {
14380                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14381                 p+= UTF8SKIP(p);
14382             }
14383
14384             /* The declaration of 'input_text' is how long we allow a potential
14385              * class name to be, before saying they didn't mean a class name at
14386              * all */
14387             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14388                 break;
14389             }
14390         }
14391
14392         /* We get to here when the possible class name hasn't been properly
14393          * terminated before:
14394          *   1) we ran off the end of the pattern; or
14395          *   2) found two characters, each of which might have been intended to
14396          *      be the name's terminator
14397          *   3) found so many punctuation characters in the purported name,
14398          *      that the edit distance to a valid one is exceeded
14399          *   4) we decided it was more characters than anyone could have
14400          *      intended to be one. */
14401
14402         found_problem = TRUE;
14403
14404         /* In the final two cases, we know that looking up what we've
14405          * accumulated won't lead to a match, even a fuzzy one. */
14406         if (   name_len >= C_ARRAY_LENGTH(input_text)
14407             || punct_count > max_distance)
14408         {
14409             /* If there was an intermediate key character that could have been
14410              * an intended end, redo the parse, but stop there */
14411             if (possible_end && possible_end != (char *) -1) {
14412                 possible_end = (char *) -1; /* Special signal value to say
14413                                                we've done a first pass */
14414                 p = name_start;
14415                 goto parse_name;
14416             }
14417
14418             /* Otherwise, it can't have meant to have been a class */
14419             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14420         }
14421
14422         /* If we ran off the end, and the final character was a punctuation
14423          * one, back up one, to look at that final one just below.  Later, we
14424          * will restore the parse pointer if appropriate */
14425         if (name_len && p == e && isPUNCT(*(p-1))) {
14426             p--;
14427             name_len--;
14428         }
14429
14430         if (p < e && isPUNCT(*p)) {
14431             if (*p == ']') {
14432                 has_terminating_bracket = TRUE;
14433
14434                 /* If this is a 2nd ']', and the first one is just below this
14435                  * one, consider that to be the real terminator.  This gives a
14436                  * uniform and better positioning for the warning message  */
14437                 if (   possible_end
14438                     && possible_end != (char *) -1
14439                     && *possible_end == ']'
14440                     && name_len && input_text[name_len - 1] == ']')
14441                 {
14442                     name_len--;
14443                     p = possible_end;
14444
14445                     /* And this is actually equivalent to having done the 2nd
14446                      * pass now, so set it to not try again */
14447                     possible_end = (char *) -1;
14448                 }
14449             }
14450             else {
14451                 if (*p == ':') {
14452                     has_terminating_colon = TRUE;
14453                 }
14454                 else if (*p == ';') {
14455                     has_semi_colon = TRUE;
14456                     has_terminating_colon = TRUE;
14457                 }
14458                 p++;
14459             }
14460         }
14461
14462     try_posix:
14463
14464         /* Here, we have a class name to look up.  We can short circuit the
14465          * stuff below for short names that can't possibly be meant to be a
14466          * class name.  (We can do this on the first pass, as any second pass
14467          * will yield an even shorter name) */
14468         if (name_len < 3) {
14469             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14470         }
14471
14472         /* Find which class it is.  Initially switch on the length of the name.
14473          * */
14474         switch (name_len) {
14475             case 4:
14476                 if (memEQ(name_start, "word", 4)) {
14477                     /* this is not POSIX, this is the Perl \w */
14478                     class_number = ANYOF_WORDCHAR;
14479                 }
14480                 break;
14481             case 5:
14482                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14483                  *                        graph lower print punct space upper
14484                  * Offset 4 gives the best switch position.  */
14485                 switch (name_start[4]) {
14486                     case 'a':
14487                         if (memEQ(name_start, "alph", 4)) /* alpha */
14488                             class_number = ANYOF_ALPHA;
14489                         break;
14490                     case 'e':
14491                         if (memEQ(name_start, "spac", 4)) /* space */
14492                             class_number = ANYOF_SPACE;
14493                         break;
14494                     case 'h':
14495                         if (memEQ(name_start, "grap", 4)) /* graph */
14496                             class_number = ANYOF_GRAPH;
14497                         break;
14498                     case 'i':
14499                         if (memEQ(name_start, "asci", 4)) /* ascii */
14500                             class_number = ANYOF_ASCII;
14501                         break;
14502                     case 'k':
14503                         if (memEQ(name_start, "blan", 4)) /* blank */
14504                             class_number = ANYOF_BLANK;
14505                         break;
14506                     case 'l':
14507                         if (memEQ(name_start, "cntr", 4)) /* cntrl */
14508                             class_number = ANYOF_CNTRL;
14509                         break;
14510                     case 'm':
14511                         if (memEQ(name_start, "alnu", 4)) /* alnum */
14512                             class_number = ANYOF_ALPHANUMERIC;
14513                         break;
14514                     case 'r':
14515                         if (memEQ(name_start, "lowe", 4)) /* lower */
14516                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
14517                         else if (memEQ(name_start, "uppe", 4)) /* upper */
14518                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
14519                         break;
14520                     case 't':
14521                         if (memEQ(name_start, "digi", 4)) /* digit */
14522                             class_number = ANYOF_DIGIT;
14523                         else if (memEQ(name_start, "prin", 4)) /* print */
14524                             class_number = ANYOF_PRINT;
14525                         else if (memEQ(name_start, "punc", 4)) /* punct */
14526                             class_number = ANYOF_PUNCT;
14527                         break;
14528                 }
14529                 break;
14530             case 6:
14531                 if (memEQ(name_start, "xdigit", 6))
14532                     class_number = ANYOF_XDIGIT;
14533                 break;
14534         }
14535
14536         /* If the name exactly matches a posix class name the class number will
14537          * here be set to it, and the input almost certainly was meant to be a
14538          * posix class, so we can skip further checking.  If instead the syntax
14539          * is exactly correct, but the name isn't one of the legal ones, we
14540          * will return that as an error below.  But if neither of these apply,
14541          * it could be that no posix class was intended at all, or that one
14542          * was, but there was a typo.  We tease these apart by doing fuzzy
14543          * matching on the name */
14544         if (class_number == OOB_NAMEDCLASS && found_problem) {
14545             const UV posix_names[][6] = {
14546                                                 { 'a', 'l', 'n', 'u', 'm' },
14547                                                 { 'a', 'l', 'p', 'h', 'a' },
14548                                                 { 'a', 's', 'c', 'i', 'i' },
14549                                                 { 'b', 'l', 'a', 'n', 'k' },
14550                                                 { 'c', 'n', 't', 'r', 'l' },
14551                                                 { 'd', 'i', 'g', 'i', 't' },
14552                                                 { 'g', 'r', 'a', 'p', 'h' },
14553                                                 { 'l', 'o', 'w', 'e', 'r' },
14554                                                 { 'p', 'r', 'i', 'n', 't' },
14555                                                 { 'p', 'u', 'n', 'c', 't' },
14556                                                 { 's', 'p', 'a', 'c', 'e' },
14557                                                 { 'u', 'p', 'p', 'e', 'r' },
14558                                                 { 'w', 'o', 'r', 'd' },
14559                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
14560                                             };
14561             /* The names of the above all have added NULs to make them the same
14562              * size, so we need to also have the real lengths */
14563             const UV posix_name_lengths[] = {
14564                                                 sizeof("alnum") - 1,
14565                                                 sizeof("alpha") - 1,
14566                                                 sizeof("ascii") - 1,
14567                                                 sizeof("blank") - 1,
14568                                                 sizeof("cntrl") - 1,
14569                                                 sizeof("digit") - 1,
14570                                                 sizeof("graph") - 1,
14571                                                 sizeof("lower") - 1,
14572                                                 sizeof("print") - 1,
14573                                                 sizeof("punct") - 1,
14574                                                 sizeof("space") - 1,
14575                                                 sizeof("upper") - 1,
14576                                                 sizeof("word")  - 1,
14577                                                 sizeof("xdigit")- 1
14578                                             };
14579             unsigned int i;
14580             int temp_max = max_distance;    /* Use a temporary, so if we
14581                                                reparse, we haven't changed the
14582                                                outer one */
14583
14584             /* Use a smaller max edit distance if we are missing one of the
14585              * delimiters */
14586             if (   has_opening_bracket + has_opening_colon < 2
14587                 || has_terminating_bracket + has_terminating_colon < 2)
14588             {
14589                 temp_max--;
14590             }
14591
14592             /* See if the input name is close to a legal one */
14593             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
14594
14595                 /* Short circuit call if the lengths are too far apart to be
14596                  * able to match */
14597                 if (abs( (int) (name_len - posix_name_lengths[i]))
14598                     > temp_max)
14599                 {
14600                     continue;
14601                 }
14602
14603                 if (edit_distance(input_text,
14604                                   posix_names[i],
14605                                   name_len,
14606                                   posix_name_lengths[i],
14607                                   temp_max
14608                                  )
14609                     > -1)
14610                 { /* If it is close, it probably was intended to be a class */
14611                     goto probably_meant_to_be;
14612                 }
14613             }
14614
14615             /* Here the input name is not close enough to a valid class name
14616              * for us to consider it to be intended to be a posix class.  If
14617              * we haven't already done so, and the parse found a character that
14618              * could have been terminators for the name, but which we absorbed
14619              * as typos during the first pass, repeat the parse, signalling it
14620              * to stop at that character */
14621             if (possible_end && possible_end != (char *) -1) {
14622                 possible_end = (char *) -1;
14623                 p = name_start;
14624                 goto parse_name;
14625             }
14626
14627             /* Here neither pass found a close-enough class name */
14628             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14629         }
14630
14631     probably_meant_to_be:
14632
14633         /* Here we think that a posix specification was intended.  Update any
14634          * parse pointer */
14635         if (updated_parse_ptr) {
14636             *updated_parse_ptr = (char *) p;
14637         }
14638
14639         /* If a posix class name was intended but incorrectly specified, we
14640          * output or return the warnings */
14641         if (found_problem) {
14642
14643             /* We set flags for these issues in the parse loop above instead of
14644              * adding them to the list of warnings, because we can parse it
14645              * twice, and we only want one warning instance */
14646             if (has_upper) {
14647                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
14648             }
14649             if (has_blank) {
14650                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14651             }
14652             if (has_semi_colon) {
14653                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14654             }
14655             else if (! has_terminating_colon) {
14656                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
14657             }
14658             if (! has_terminating_bracket) {
14659                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
14660             }
14661
14662             if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
14663                 *posix_warnings = RExC_warn_text;
14664             }
14665         }
14666         else if (class_number != OOB_NAMEDCLASS) {
14667             /* If it is a known class, return the class.  The class number
14668              * #defines are structured so each complement is +1 to the normal
14669              * one */
14670             return class_number + complement;
14671         }
14672         else if (! check_only) {
14673
14674             /* Here, it is an unrecognized class.  This is an error (unless the
14675             * call is to check only, which we've already handled above) */
14676             const char * const complement_string = (complement)
14677                                                    ? "^"
14678                                                    : "";
14679             RExC_parse = (char *) p;
14680             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
14681                         complement_string,
14682                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
14683         }
14684     }
14685
14686     return OOB_NAMEDCLASS;
14687 }
14688 #undef ADD_POSIX_WARNING
14689
14690 STATIC unsigned  int
14691 S_regex_set_precedence(const U8 my_operator) {
14692
14693     /* Returns the precedence in the (?[...]) construct of the input operator,
14694      * specified by its character representation.  The precedence follows
14695      * general Perl rules, but it extends this so that ')' and ']' have (low)
14696      * precedence even though they aren't really operators */
14697
14698     switch (my_operator) {
14699         case '!':
14700             return 5;
14701         case '&':
14702             return 4;
14703         case '^':
14704         case '|':
14705         case '+':
14706         case '-':
14707             return 3;
14708         case ')':
14709             return 2;
14710         case ']':
14711             return 1;
14712     }
14713
14714     NOT_REACHED; /* NOTREACHED */
14715     return 0;   /* Silence compiler warning */
14716 }
14717
14718 STATIC regnode *
14719 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
14720                     I32 *flagp, U32 depth,
14721                     char * const oregcomp_parse)
14722 {
14723     /* Handle the (?[...]) construct to do set operations */
14724
14725     U8 curchar;                     /* Current character being parsed */
14726     UV start, end;                  /* End points of code point ranges */
14727     SV* final = NULL;               /* The end result inversion list */
14728     SV* result_string;              /* 'final' stringified */
14729     AV* stack;                      /* stack of operators and operands not yet
14730                                        resolved */
14731     AV* fence_stack = NULL;         /* A stack containing the positions in
14732                                        'stack' of where the undealt-with left
14733                                        parens would be if they were actually
14734                                        put there */
14735     /* The 'VOL' (expanding to 'volatile') is a workaround for an optimiser bug
14736      * in Solaris Studio 12.3. See RT #127455 */
14737     VOL IV fence = 0;               /* Position of where most recent undealt-
14738                                        with left paren in stack is; -1 if none.
14739                                      */
14740     STRLEN len;                     /* Temporary */
14741     regnode* node;                  /* Temporary, and final regnode returned by
14742                                        this function */
14743     const bool save_fold = FOLD;    /* Temporary */
14744     char *save_end, *save_parse;    /* Temporaries */
14745     const bool in_locale = LOC;     /* we turn off /l during processing */
14746     AV* posix_warnings = NULL;
14747
14748     GET_RE_DEBUG_FLAGS_DECL;
14749
14750     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
14751
14752     if (in_locale) {
14753         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
14754     }
14755
14756     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
14757                                          This is required so that the compile
14758                                          time values are valid in all runtime
14759                                          cases */
14760
14761     /* This will return only an ANYOF regnode, or (unlikely) something smaller
14762      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
14763      * call regclass to handle '[]' so as to not have to reinvent its parsing
14764      * rules here (throwing away the size it computes each time).  And, we exit
14765      * upon an unescaped ']' that isn't one ending a regclass.  To do both
14766      * these things, we need to realize that something preceded by a backslash
14767      * is escaped, so we have to keep track of backslashes */
14768     if (SIZE_ONLY) {
14769         UV depth = 0; /* how many nested (?[...]) constructs */
14770
14771         while (RExC_parse < RExC_end) {
14772             SV* current = NULL;
14773
14774             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14775                                     TRUE /* Force /x */ );
14776
14777             switch (*RExC_parse) {
14778                 case '?':
14779                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
14780                     /* FALLTHROUGH */
14781                 default:
14782                     break;
14783                 case '\\':
14784                     /* Skip past this, so the next character gets skipped, after
14785                      * the switch */
14786                     RExC_parse++;
14787                     if (*RExC_parse == 'c') {
14788                             /* Skip the \cX notation for control characters */
14789                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14790                     }
14791                     break;
14792
14793                 case '[':
14794                 {
14795                     /* See if this is a [:posix:] class. */
14796                     bool is_posix_class = (OOB_NAMEDCLASS
14797                             < handle_possible_posix(pRExC_state,
14798                                                 RExC_parse + 1,
14799                                                 NULL,
14800                                                 NULL,
14801                                                 TRUE /* checking only */));
14802                     /* If it is a posix class, leave the parse pointer at the
14803                      * '[' to fool regclass() into thinking it is part of a
14804                      * '[[:posix:]]'. */
14805                     if (! is_posix_class) {
14806                         RExC_parse++;
14807                     }
14808
14809                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
14810                      * if multi-char folds are allowed.  */
14811                     if (!regclass(pRExC_state, flagp,depth+1,
14812                                   is_posix_class, /* parse the whole char
14813                                                      class only if not a
14814                                                      posix class */
14815                                   FALSE, /* don't allow multi-char folds */
14816                                   TRUE, /* silence non-portable warnings. */
14817                                   TRUE, /* strict */
14818                                   FALSE, /* Require return to be an ANYOF */
14819                                   &current,
14820                                   &posix_warnings
14821                                  ))
14822                         FAIL2("panic: regclass returned NULL to handle_sets, "
14823                               "flags=%#" UVxf, (UV) *flagp);
14824
14825                     /* function call leaves parse pointing to the ']', except
14826                      * if we faked it */
14827                     if (is_posix_class) {
14828                         RExC_parse--;
14829                     }
14830
14831                     SvREFCNT_dec(current);   /* In case it returned something */
14832                     break;
14833                 }
14834
14835                 case ']':
14836                     if (depth--) break;
14837                     RExC_parse++;
14838                     if (*RExC_parse == ')') {
14839                         node = reganode(pRExC_state, ANYOF, 0);
14840                         RExC_size += ANYOF_SKIP;
14841                         nextchar(pRExC_state);
14842                         Set_Node_Length(node,
14843                                 RExC_parse - oregcomp_parse + 1); /* MJD */
14844                         if (in_locale) {
14845                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
14846                         }
14847
14848                         return node;
14849                     }
14850                     goto no_close;
14851             }
14852
14853             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14854         }
14855
14856       no_close:
14857         /* We output the messages even if warnings are off, because we'll fail
14858          * the very next thing, and these give a likely diagnosis for that */
14859         if (posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
14860             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
14861         }
14862
14863         FAIL("Syntax error in (?[...])");
14864     }
14865
14866     /* Pass 2 only after this. */
14867     Perl_ck_warner_d(aTHX_
14868         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
14869         "The regex_sets feature is experimental" REPORT_LOCATION,
14870         REPORT_LOCATION_ARGS(RExC_parse));
14871
14872     /* Everything in this construct is a metacharacter.  Operands begin with
14873      * either a '\' (for an escape sequence), or a '[' for a bracketed
14874      * character class.  Any other character should be an operator, or
14875      * parenthesis for grouping.  Both types of operands are handled by calling
14876      * regclass() to parse them.  It is called with a parameter to indicate to
14877      * return the computed inversion list.  The parsing here is implemented via
14878      * a stack.  Each entry on the stack is a single character representing one
14879      * of the operators; or else a pointer to an operand inversion list. */
14880
14881 #define IS_OPERATOR(a) SvIOK(a)
14882 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
14883
14884     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
14885      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
14886      * with pronouncing it called it Reverse Polish instead, but now that YOU
14887      * know how to pronounce it you can use the correct term, thus giving due
14888      * credit to the person who invented it, and impressing your geek friends.
14889      * Wikipedia says that the pronounciation of "Ł" has been changing so that
14890      * it is now more like an English initial W (as in wonk) than an L.)
14891      *
14892      * This means that, for example, 'a | b & c' is stored on the stack as
14893      *
14894      * c  [4]
14895      * b  [3]
14896      * &  [2]
14897      * a  [1]
14898      * |  [0]
14899      *
14900      * where the numbers in brackets give the stack [array] element number.
14901      * In this implementation, parentheses are not stored on the stack.
14902      * Instead a '(' creates a "fence" so that the part of the stack below the
14903      * fence is invisible except to the corresponding ')' (this allows us to
14904      * replace testing for parens, by using instead subtraction of the fence
14905      * position).  As new operands are processed they are pushed onto the stack
14906      * (except as noted in the next paragraph).  New operators of higher
14907      * precedence than the current final one are inserted on the stack before
14908      * the lhs operand (so that when the rhs is pushed next, everything will be
14909      * in the correct positions shown above.  When an operator of equal or
14910      * lower precedence is encountered in parsing, all the stacked operations
14911      * of equal or higher precedence are evaluated, leaving the result as the
14912      * top entry on the stack.  This makes higher precedence operations
14913      * evaluate before lower precedence ones, and causes operations of equal
14914      * precedence to left associate.
14915      *
14916      * The only unary operator '!' is immediately pushed onto the stack when
14917      * encountered.  When an operand is encountered, if the top of the stack is
14918      * a '!", the complement is immediately performed, and the '!' popped.  The
14919      * resulting value is treated as a new operand, and the logic in the
14920      * previous paragraph is executed.  Thus in the expression
14921      *      [a] + ! [b]
14922      * the stack looks like
14923      *
14924      * !
14925      * a
14926      * +
14927      *
14928      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
14929      * becomes
14930      *
14931      * !b
14932      * a
14933      * +
14934      *
14935      * A ')' is treated as an operator with lower precedence than all the
14936      * aforementioned ones, which causes all operations on the stack above the
14937      * corresponding '(' to be evaluated down to a single resultant operand.
14938      * Then the fence for the '(' is removed, and the operand goes through the
14939      * algorithm above, without the fence.
14940      *
14941      * A separate stack is kept of the fence positions, so that the position of
14942      * the latest so-far unbalanced '(' is at the top of it.
14943      *
14944      * The ']' ending the construct is treated as the lowest operator of all,
14945      * so that everything gets evaluated down to a single operand, which is the
14946      * result */
14947
14948     sv_2mortal((SV *)(stack = newAV()));
14949     sv_2mortal((SV *)(fence_stack = newAV()));
14950
14951     while (RExC_parse < RExC_end) {
14952         I32 top_index;              /* Index of top-most element in 'stack' */
14953         SV** top_ptr;               /* Pointer to top 'stack' element */
14954         SV* current = NULL;         /* To contain the current inversion list
14955                                        operand */
14956         SV* only_to_avoid_leaks;
14957
14958         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14959                                 TRUE /* Force /x */ );
14960         if (RExC_parse >= RExC_end) {
14961             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
14962         }
14963
14964         curchar = UCHARAT(RExC_parse);
14965
14966 redo_curchar:
14967
14968 #ifdef ENABLE_REGEX_SETS_DEBUGGING
14969                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
14970         DEBUG_U(dump_regex_sets_structures(pRExC_state,
14971                                            stack, fence, fence_stack));
14972 #endif
14973
14974         top_index = av_tindex_nomg(stack);
14975
14976         switch (curchar) {
14977             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
14978             char stacked_operator;  /* The topmost operator on the 'stack'. */
14979             SV* lhs;                /* Operand to the left of the operator */
14980             SV* rhs;                /* Operand to the right of the operator */
14981             SV* fence_ptr;          /* Pointer to top element of the fence
14982                                        stack */
14983
14984             case '(':
14985
14986                 if (   RExC_parse < RExC_end - 1
14987                     && (UCHARAT(RExC_parse + 1) == '?'))
14988                 {
14989                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
14990                      * This happens when we have some thing like
14991                      *
14992                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
14993                      *   ...
14994                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
14995                      *
14996                      * Here we would be handling the interpolated
14997                      * '$thai_or_lao'.  We handle this by a recursive call to
14998                      * ourselves which returns the inversion list the
14999                      * interpolated expression evaluates to.  We use the flags
15000                      * from the interpolated pattern. */
15001                     U32 save_flags = RExC_flags;
15002                     const char * save_parse;
15003
15004                     RExC_parse += 2;        /* Skip past the '(?' */
15005                     save_parse = RExC_parse;
15006
15007                     /* Parse any flags for the '(?' */
15008                     parse_lparen_question_flags(pRExC_state);
15009
15010                     if (RExC_parse == save_parse  /* Makes sure there was at
15011                                                      least one flag (or else
15012                                                      this embedding wasn't
15013                                                      compiled) */
15014                         || RExC_parse >= RExC_end - 4
15015                         || UCHARAT(RExC_parse) != ':'
15016                         || UCHARAT(++RExC_parse) != '('
15017                         || UCHARAT(++RExC_parse) != '?'
15018                         || UCHARAT(++RExC_parse) != '[')
15019                     {
15020
15021                         /* In combination with the above, this moves the
15022                          * pointer to the point just after the first erroneous
15023                          * character (or if there are no flags, to where they
15024                          * should have been) */
15025                         if (RExC_parse >= RExC_end - 4) {
15026                             RExC_parse = RExC_end;
15027                         }
15028                         else if (RExC_parse != save_parse) {
15029                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15030                         }
15031                         vFAIL("Expecting '(?flags:(?[...'");
15032                     }
15033
15034                     /* Recurse, with the meat of the embedded expression */
15035                     RExC_parse++;
15036                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15037                                                     depth+1, oregcomp_parse);
15038
15039                     /* Here, 'current' contains the embedded expression's
15040                      * inversion list, and RExC_parse points to the trailing
15041                      * ']'; the next character should be the ')' */
15042                     RExC_parse++;
15043                     assert(UCHARAT(RExC_parse) == ')');
15044
15045                     /* Then the ')' matching the original '(' handled by this
15046                      * case: statement */
15047                     RExC_parse++;
15048                     assert(UCHARAT(RExC_parse) == ')');
15049
15050                     RExC_parse++;
15051                     RExC_flags = save_flags;
15052                     goto handle_operand;
15053                 }
15054
15055                 /* A regular '('.  Look behind for illegal syntax */
15056                 if (top_index - fence >= 0) {
15057                     /* If the top entry on the stack is an operator, it had
15058                      * better be a '!', otherwise the entry below the top
15059                      * operand should be an operator */
15060                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15061                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15062                         || (   IS_OPERAND(*top_ptr)
15063                             && (   top_index - fence < 1
15064                                 || ! (stacked_ptr = av_fetch(stack,
15065                                                              top_index - 1,
15066                                                              FALSE))
15067                                 || ! IS_OPERATOR(*stacked_ptr))))
15068                     {
15069                         RExC_parse++;
15070                         vFAIL("Unexpected '(' with no preceding operator");
15071                     }
15072                 }
15073
15074                 /* Stack the position of this undealt-with left paren */
15075                 av_push(fence_stack, newSViv(fence));
15076                 fence = top_index + 1;
15077                 break;
15078
15079             case '\\':
15080                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15081                  * multi-char folds are allowed.  */
15082                 if (!regclass(pRExC_state, flagp,depth+1,
15083                               TRUE, /* means parse just the next thing */
15084                               FALSE, /* don't allow multi-char folds */
15085                               FALSE, /* don't silence non-portable warnings.  */
15086                               TRUE,  /* strict */
15087                               FALSE, /* Require return to be an ANYOF */
15088                               &current,
15089                               NULL))
15090                 {
15091                     FAIL2("panic: regclass returned NULL to handle_sets, "
15092                           "flags=%#" UVxf, (UV) *flagp);
15093                 }
15094
15095                 /* regclass() will return with parsing just the \ sequence,
15096                  * leaving the parse pointer at the next thing to parse */
15097                 RExC_parse--;
15098                 goto handle_operand;
15099
15100             case '[':   /* Is a bracketed character class */
15101             {
15102                 /* See if this is a [:posix:] class. */
15103                 bool is_posix_class = (OOB_NAMEDCLASS
15104                             < handle_possible_posix(pRExC_state,
15105                                                 RExC_parse + 1,
15106                                                 NULL,
15107                                                 NULL,
15108                                                 TRUE /* checking only */));
15109                 /* If it is a posix class, leave the parse pointer at the '['
15110                  * to fool regclass() into thinking it is part of a
15111                  * '[[:posix:]]'. */
15112                 if (! is_posix_class) {
15113                     RExC_parse++;
15114                 }
15115
15116                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15117                  * multi-char folds are allowed.  */
15118                 if (!regclass(pRExC_state, flagp,depth+1,
15119                                 is_posix_class, /* parse the whole char
15120                                                     class only if not a
15121                                                     posix class */
15122                                 FALSE, /* don't allow multi-char folds */
15123                                 TRUE, /* silence non-portable warnings. */
15124                                 TRUE, /* strict */
15125                                 FALSE, /* Require return to be an ANYOF */
15126                                 &current,
15127                                 NULL
15128                                 ))
15129                 {
15130                     FAIL2("panic: regclass returned NULL to handle_sets, "
15131                           "flags=%#" UVxf, (UV) *flagp);
15132                 }
15133
15134                 /* function call leaves parse pointing to the ']', except if we
15135                  * faked it */
15136                 if (is_posix_class) {
15137                     RExC_parse--;
15138                 }
15139
15140                 goto handle_operand;
15141             }
15142
15143             case ']':
15144                 if (top_index >= 1) {
15145                     goto join_operators;
15146                 }
15147
15148                 /* Only a single operand on the stack: are done */
15149                 goto done;
15150
15151             case ')':
15152                 if (av_tindex_nomg(fence_stack) < 0) {
15153                     RExC_parse++;
15154                     vFAIL("Unexpected ')'");
15155                 }
15156
15157                 /* If nothing after the fence, is missing an operand */
15158                 if (top_index - fence < 0) {
15159                     RExC_parse++;
15160                     goto bad_syntax;
15161                 }
15162                 /* If at least two things on the stack, treat this as an
15163                   * operator */
15164                 if (top_index - fence >= 1) {
15165                     goto join_operators;
15166                 }
15167
15168                 /* Here only a single thing on the fenced stack, and there is a
15169                  * fence.  Get rid of it */
15170                 fence_ptr = av_pop(fence_stack);
15171                 assert(fence_ptr);
15172                 fence = SvIV(fence_ptr) - 1;
15173                 SvREFCNT_dec_NN(fence_ptr);
15174                 fence_ptr = NULL;
15175
15176                 if (fence < 0) {
15177                     fence = 0;
15178                 }
15179
15180                 /* Having gotten rid of the fence, we pop the operand at the
15181                  * stack top and process it as a newly encountered operand */
15182                 current = av_pop(stack);
15183                 if (IS_OPERAND(current)) {
15184                     goto handle_operand;
15185                 }
15186
15187                 RExC_parse++;
15188                 goto bad_syntax;
15189
15190             case '&':
15191             case '|':
15192             case '+':
15193             case '-':
15194             case '^':
15195
15196                 /* These binary operators should have a left operand already
15197                  * parsed */
15198                 if (   top_index - fence < 0
15199                     || top_index - fence == 1
15200                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15201                     || ! IS_OPERAND(*top_ptr))
15202                 {
15203                     goto unexpected_binary;
15204                 }
15205
15206                 /* If only the one operand is on the part of the stack visible
15207                  * to us, we just place this operator in the proper position */
15208                 if (top_index - fence < 2) {
15209
15210                     /* Place the operator before the operand */
15211
15212                     SV* lhs = av_pop(stack);
15213                     av_push(stack, newSVuv(curchar));
15214                     av_push(stack, lhs);
15215                     break;
15216                 }
15217
15218                 /* But if there is something else on the stack, we need to
15219                  * process it before this new operator if and only if the
15220                  * stacked operation has equal or higher precedence than the
15221                  * new one */
15222
15223              join_operators:
15224
15225                 /* The operator on the stack is supposed to be below both its
15226                  * operands */
15227                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15228                     || IS_OPERAND(*stacked_ptr))
15229                 {
15230                     /* But if not, it's legal and indicates we are completely
15231                      * done if and only if we're currently processing a ']',
15232                      * which should be the final thing in the expression */
15233                     if (curchar == ']') {
15234                         goto done;
15235                     }
15236
15237                   unexpected_binary:
15238                     RExC_parse++;
15239                     vFAIL2("Unexpected binary operator '%c' with no "
15240                            "preceding operand", curchar);
15241                 }
15242                 stacked_operator = (char) SvUV(*stacked_ptr);
15243
15244                 if (regex_set_precedence(curchar)
15245                     > regex_set_precedence(stacked_operator))
15246                 {
15247                     /* Here, the new operator has higher precedence than the
15248                      * stacked one.  This means we need to add the new one to
15249                      * the stack to await its rhs operand (and maybe more
15250                      * stuff).  We put it before the lhs operand, leaving
15251                      * untouched the stacked operator and everything below it
15252                      * */
15253                     lhs = av_pop(stack);
15254                     assert(IS_OPERAND(lhs));
15255
15256                     av_push(stack, newSVuv(curchar));
15257                     av_push(stack, lhs);
15258                     break;
15259                 }
15260
15261                 /* Here, the new operator has equal or lower precedence than
15262                  * what's already there.  This means the operation already
15263                  * there should be performed now, before the new one. */
15264
15265                 rhs = av_pop(stack);
15266                 if (! IS_OPERAND(rhs)) {
15267
15268                     /* This can happen when a ! is not followed by an operand,
15269                      * like in /(?[\t &!])/ */
15270                     goto bad_syntax;
15271                 }
15272
15273                 lhs = av_pop(stack);
15274
15275                 if (! IS_OPERAND(lhs)) {
15276
15277                     /* This can happen when there is an empty (), like in
15278                      * /(?[[0]+()+])/ */
15279                     goto bad_syntax;
15280                 }
15281
15282                 switch (stacked_operator) {
15283                     case '&':
15284                         _invlist_intersection(lhs, rhs, &rhs);
15285                         break;
15286
15287                     case '|':
15288                     case '+':
15289                         _invlist_union(lhs, rhs, &rhs);
15290                         break;
15291
15292                     case '-':
15293                         _invlist_subtract(lhs, rhs, &rhs);
15294                         break;
15295
15296                     case '^':   /* The union minus the intersection */
15297                     {
15298                         SV* i = NULL;
15299                         SV* u = NULL;
15300
15301                         _invlist_union(lhs, rhs, &u);
15302                         _invlist_intersection(lhs, rhs, &i);
15303                         _invlist_subtract(u, i, &rhs);
15304                         SvREFCNT_dec_NN(i);
15305                         SvREFCNT_dec_NN(u);
15306                         break;
15307                     }
15308                 }
15309                 SvREFCNT_dec(lhs);
15310
15311                 /* Here, the higher precedence operation has been done, and the
15312                  * result is in 'rhs'.  We overwrite the stacked operator with
15313                  * the result.  Then we redo this code to either push the new
15314                  * operator onto the stack or perform any higher precedence
15315                  * stacked operation */
15316                 only_to_avoid_leaks = av_pop(stack);
15317                 SvREFCNT_dec(only_to_avoid_leaks);
15318                 av_push(stack, rhs);
15319                 goto redo_curchar;
15320
15321             case '!':   /* Highest priority, right associative */
15322
15323                 /* If what's already at the top of the stack is another '!",
15324                  * they just cancel each other out */
15325                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15326                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15327                 {
15328                     only_to_avoid_leaks = av_pop(stack);
15329                     SvREFCNT_dec(only_to_avoid_leaks);
15330                 }
15331                 else { /* Otherwise, since it's right associative, just push
15332                           onto the stack */
15333                     av_push(stack, newSVuv(curchar));
15334                 }
15335                 break;
15336
15337             default:
15338                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15339                 vFAIL("Unexpected character");
15340
15341           handle_operand:
15342
15343             /* Here 'current' is the operand.  If something is already on the
15344              * stack, we have to check if it is a !.  But first, the code above
15345              * may have altered the stack in the time since we earlier set
15346              * 'top_index'.  */
15347
15348             top_index = av_tindex_nomg(stack);
15349             if (top_index - fence >= 0) {
15350                 /* If the top entry on the stack is an operator, it had better
15351                  * be a '!', otherwise the entry below the top operand should
15352                  * be an operator */
15353                 top_ptr = av_fetch(stack, top_index, FALSE);
15354                 assert(top_ptr);
15355                 if (IS_OPERATOR(*top_ptr)) {
15356
15357                     /* The only permissible operator at the top of the stack is
15358                      * '!', which is applied immediately to this operand. */
15359                     curchar = (char) SvUV(*top_ptr);
15360                     if (curchar != '!') {
15361                         SvREFCNT_dec(current);
15362                         vFAIL2("Unexpected binary operator '%c' with no "
15363                                 "preceding operand", curchar);
15364                     }
15365
15366                     _invlist_invert(current);
15367
15368                     only_to_avoid_leaks = av_pop(stack);
15369                     SvREFCNT_dec(only_to_avoid_leaks);
15370
15371                     /* And we redo with the inverted operand.  This allows
15372                      * handling multiple ! in a row */
15373                     goto handle_operand;
15374                 }
15375                           /* Single operand is ok only for the non-binary ')'
15376                            * operator */
15377                 else if ((top_index - fence == 0 && curchar != ')')
15378                          || (top_index - fence > 0
15379                              && (! (stacked_ptr = av_fetch(stack,
15380                                                            top_index - 1,
15381                                                            FALSE))
15382                                  || IS_OPERAND(*stacked_ptr))))
15383                 {
15384                     SvREFCNT_dec(current);
15385                     vFAIL("Operand with no preceding operator");
15386                 }
15387             }
15388
15389             /* Here there was nothing on the stack or the top element was
15390              * another operand.  Just add this new one */
15391             av_push(stack, current);
15392
15393         } /* End of switch on next parse token */
15394
15395         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15396     } /* End of loop parsing through the construct */
15397
15398   done:
15399     if (av_tindex_nomg(fence_stack) >= 0) {
15400         vFAIL("Unmatched (");
15401     }
15402
15403     if (av_tindex_nomg(stack) < 0   /* Was empty */
15404         || ((final = av_pop(stack)) == NULL)
15405         || ! IS_OPERAND(final)
15406         || SvTYPE(final) != SVt_INVLIST
15407         || av_tindex_nomg(stack) >= 0)  /* More left on stack */
15408     {
15409       bad_syntax:
15410         SvREFCNT_dec(final);
15411         vFAIL("Incomplete expression within '(?[ ])'");
15412     }
15413
15414     /* Here, 'final' is the resultant inversion list from evaluating the
15415      * expression.  Return it if so requested */
15416     if (return_invlist) {
15417         *return_invlist = final;
15418         return END;
15419     }
15420
15421     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15422      * expecting a string of ranges and individual code points */
15423     invlist_iterinit(final);
15424     result_string = newSVpvs("");
15425     while (invlist_iternext(final, &start, &end)) {
15426         if (start == end) {
15427             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
15428         }
15429         else {
15430             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
15431                                                      start,          end);
15432         }
15433     }
15434
15435     /* About to generate an ANYOF (or similar) node from the inversion list we
15436      * have calculated */
15437     save_parse = RExC_parse;
15438     RExC_parse = SvPV(result_string, len);
15439     save_end = RExC_end;
15440     RExC_end = RExC_parse + len;
15441
15442     /* We turn off folding around the call, as the class we have constructed
15443      * already has all folding taken into consideration, and we don't want
15444      * regclass() to add to that */
15445     RExC_flags &= ~RXf_PMf_FOLD;
15446     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15447      * folds are allowed.  */
15448     node = regclass(pRExC_state, flagp,depth+1,
15449                     FALSE, /* means parse the whole char class */
15450                     FALSE, /* don't allow multi-char folds */
15451                     TRUE, /* silence non-portable warnings.  The above may very
15452                              well have generated non-portable code points, but
15453                              they're valid on this machine */
15454                     FALSE, /* similarly, no need for strict */
15455                     FALSE, /* Require return to be an ANYOF */
15456                     NULL,
15457                     NULL
15458                 );
15459     if (!node)
15460         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#" UVxf,
15461                     PTR2UV(flagp));
15462
15463     /* Fix up the node type if we are in locale.  (We have pretended we are
15464      * under /u for the purposes of regclass(), as this construct will only
15465      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15466      * as to cause any warnings about bad locales to be output in regexec.c),
15467      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15468      * reason we above forbid optimization into something other than an ANYOF
15469      * node is simply to minimize the number of code changes in regexec.c.
15470      * Otherwise we would have to create new EXACTish node types and deal with
15471      * them.  This decision could be revisited should this construct become
15472      * popular.
15473      *
15474      * (One might think we could look at the resulting ANYOF node and suppress
15475      * the flag if everything is above 255, as those would be UTF-8 only,
15476      * but this isn't true, as the components that led to that result could
15477      * have been locale-affected, and just happen to cancel each other out
15478      * under UTF-8 locales.) */
15479     if (in_locale) {
15480         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15481
15482         assert(OP(node) == ANYOF);
15483
15484         OP(node) = ANYOFL;
15485         ANYOF_FLAGS(node)
15486                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
15487     }
15488
15489     if (save_fold) {
15490         RExC_flags |= RXf_PMf_FOLD;
15491     }
15492
15493     RExC_parse = save_parse + 1;
15494     RExC_end = save_end;
15495     SvREFCNT_dec_NN(final);
15496     SvREFCNT_dec_NN(result_string);
15497
15498     nextchar(pRExC_state);
15499     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
15500     return node;
15501 }
15502
15503 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15504
15505 STATIC void
15506 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
15507                              AV * stack, const IV fence, AV * fence_stack)
15508 {   /* Dumps the stacks in handle_regex_sets() */
15509
15510     const SSize_t stack_top = av_tindex_nomg(stack);
15511     const SSize_t fence_stack_top = av_tindex_nomg(fence_stack);
15512     SSize_t i;
15513
15514     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
15515
15516     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
15517
15518     if (stack_top < 0) {
15519         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
15520     }
15521     else {
15522         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
15523         for (i = stack_top; i >= 0; i--) {
15524             SV ** element_ptr = av_fetch(stack, i, FALSE);
15525             if (! element_ptr) {
15526             }
15527
15528             if (IS_OPERATOR(*element_ptr)) {
15529                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
15530                                             (int) i, (int) SvIV(*element_ptr));
15531             }
15532             else {
15533                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
15534                 sv_dump(*element_ptr);
15535             }
15536         }
15537     }
15538
15539     if (fence_stack_top < 0) {
15540         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
15541     }
15542     else {
15543         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
15544         for (i = fence_stack_top; i >= 0; i--) {
15545             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
15546             if (! element_ptr) {
15547             }
15548
15549             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
15550                                             (int) i, (int) SvIV(*element_ptr));
15551         }
15552     }
15553 }
15554
15555 #endif
15556
15557 #undef IS_OPERATOR
15558 #undef IS_OPERAND
15559
15560 STATIC void
15561 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
15562 {
15563     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
15564      * innocent-looking character class, like /[ks]/i won't have to go out to
15565      * disk to find the possible matches.
15566      *
15567      * This should be called only for a Latin1-range code points, cp, which is
15568      * known to be involved in a simple fold with other code points above
15569      * Latin1.  It would give false results if /aa has been specified.
15570      * Multi-char folds are outside the scope of this, and must be handled
15571      * specially.
15572      *
15573      * XXX It would be better to generate these via regen, in case a new
15574      * version of the Unicode standard adds new mappings, though that is not
15575      * really likely, and may be caught by the default: case of the switch
15576      * below. */
15577
15578     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
15579
15580     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
15581
15582     switch (cp) {
15583         case 'k':
15584         case 'K':
15585           *invlist =
15586              add_cp_to_invlist(*invlist, KELVIN_SIGN);
15587             break;
15588         case 's':
15589         case 'S':
15590           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
15591             break;
15592         case MICRO_SIGN:
15593           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
15594           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
15595             break;
15596         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
15597         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
15598           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
15599             break;
15600         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
15601           *invlist = add_cp_to_invlist(*invlist,
15602                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
15603             break;
15604
15605 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
15606
15607         case LATIN_SMALL_LETTER_SHARP_S:
15608           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
15609             break;
15610
15611 #endif
15612
15613 #if    UNICODE_MAJOR_VERSION < 3                                        \
15614    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
15615
15616         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
15617          * U+0131.  */
15618         case 'i':
15619         case 'I':
15620           *invlist =
15621              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
15622 #   if UNICODE_DOT_DOT_VERSION == 1
15623           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
15624 #   endif
15625             break;
15626 #endif
15627
15628         default:
15629             /* Use deprecated warning to increase the chances of this being
15630              * output */
15631             if (PASS2) {
15632                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
15633             }
15634             break;
15635     }
15636 }
15637
15638 STATIC void
15639 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
15640 {
15641     /* If the final parameter is NULL, output the elements of the array given
15642      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
15643      * pushed onto it, (creating if necessary) */
15644
15645     SV * msg;
15646     const bool first_is_fatal =  ! return_posix_warnings
15647                                 && ckDEAD(packWARN(WARN_REGEXP));
15648
15649     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
15650
15651     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
15652         if (return_posix_warnings) {
15653             if (! *return_posix_warnings) { /* mortalize to not leak if
15654                                                warnings are fatal */
15655                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
15656             }
15657             av_push(*return_posix_warnings, msg);
15658         }
15659         else {
15660             if (first_is_fatal) {           /* Avoid leaking this */
15661                 av_undef(posix_warnings);   /* This isn't necessary if the
15662                                                array is mortal, but is a
15663                                                fail-safe */
15664                 (void) sv_2mortal(msg);
15665                 if (PASS2) {
15666                     SAVEFREESV(RExC_rx_sv);
15667                 }
15668             }
15669             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
15670             SvREFCNT_dec_NN(msg);
15671         }
15672     }
15673 }
15674
15675 STATIC AV *
15676 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
15677 {
15678     /* This adds the string scalar <multi_string> to the array
15679      * <multi_char_matches>.  <multi_string> is known to have exactly
15680      * <cp_count> code points in it.  This is used when constructing a
15681      * bracketed character class and we find something that needs to match more
15682      * than a single character.
15683      *
15684      * <multi_char_matches> is actually an array of arrays.  Each top-level
15685      * element is an array that contains all the strings known so far that are
15686      * the same length.  And that length (in number of code points) is the same
15687      * as the index of the top-level array.  Hence, the [2] element is an
15688      * array, each element thereof is a string containing TWO code points;
15689      * while element [3] is for strings of THREE characters, and so on.  Since
15690      * this is for multi-char strings there can never be a [0] nor [1] element.
15691      *
15692      * When we rewrite the character class below, we will do so such that the
15693      * longest strings are written first, so that it prefers the longest
15694      * matching strings first.  This is done even if it turns out that any
15695      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
15696      * Christiansen has agreed that this is ok.  This makes the test for the
15697      * ligature 'ffi' come before the test for 'ff', for example */
15698
15699     AV* this_array;
15700     AV** this_array_ptr;
15701
15702     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
15703
15704     if (! multi_char_matches) {
15705         multi_char_matches = newAV();
15706     }
15707
15708     if (av_exists(multi_char_matches, cp_count)) {
15709         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
15710         this_array = *this_array_ptr;
15711     }
15712     else {
15713         this_array = newAV();
15714         av_store(multi_char_matches, cp_count,
15715                  (SV*) this_array);
15716     }
15717     av_push(this_array, multi_string);
15718
15719     return multi_char_matches;
15720 }
15721
15722 /* The names of properties whose definitions are not known at compile time are
15723  * stored in this SV, after a constant heading.  So if the length has been
15724  * changed since initialization, then there is a run-time definition. */
15725 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
15726                                         (SvCUR(listsv) != initial_listsv_len)
15727
15728 /* There is a restricted set of white space characters that are legal when
15729  * ignoring white space in a bracketed character class.  This generates the
15730  * code to skip them.
15731  *
15732  * There is a line below that uses the same white space criteria but is outside
15733  * this macro.  Both here and there must use the same definition */
15734 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
15735     STMT_START {                                                        \
15736         if (do_skip) {                                                  \
15737             while (isBLANK_A(UCHARAT(p)))                               \
15738             {                                                           \
15739                 p++;                                                    \
15740             }                                                           \
15741         }                                                               \
15742     } STMT_END
15743
15744 STATIC regnode *
15745 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
15746                  const bool stop_at_1,  /* Just parse the next thing, don't
15747                                            look for a full character class */
15748                  bool allow_multi_folds,
15749                  const bool silence_non_portable,   /* Don't output warnings
15750                                                        about too large
15751                                                        characters */
15752                  const bool strict,
15753                  bool optimizable,                  /* ? Allow a non-ANYOF return
15754                                                        node */
15755                  SV** ret_invlist, /* Return an inversion list, not a node */
15756                  AV** return_posix_warnings
15757           )
15758 {
15759     /* parse a bracketed class specification.  Most of these will produce an
15760      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
15761      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
15762      * under /i with multi-character folds: it will be rewritten following the
15763      * paradigm of this example, where the <multi-fold>s are characters which
15764      * fold to multiple character sequences:
15765      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
15766      * gets effectively rewritten as:
15767      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
15768      * reg() gets called (recursively) on the rewritten version, and this
15769      * function will return what it constructs.  (Actually the <multi-fold>s
15770      * aren't physically removed from the [abcdefghi], it's just that they are
15771      * ignored in the recursion by means of a flag:
15772      * <RExC_in_multi_char_class>.)
15773      *
15774      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
15775      * characters, with the corresponding bit set if that character is in the
15776      * list.  For characters above this, a range list or swash is used.  There
15777      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
15778      * determinable at compile time
15779      *
15780      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
15781      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
15782      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
15783      */
15784
15785     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
15786     IV range = 0;
15787     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
15788     regnode *ret;
15789     STRLEN numlen;
15790     int namedclass = OOB_NAMEDCLASS;
15791     char *rangebegin = NULL;
15792     bool need_class = 0;
15793     SV *listsv = NULL;
15794     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
15795                                       than just initialized.  */
15796     SV* properties = NULL;    /* Code points that match \p{} \P{} */
15797     SV* posixes = NULL;     /* Code points that match classes like [:word:],
15798                                extended beyond the Latin1 range.  These have to
15799                                be kept separate from other code points for much
15800                                of this function because their handling  is
15801                                different under /i, and for most classes under
15802                                /d as well */
15803     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
15804                                separate for a while from the non-complemented
15805                                versions because of complications with /d
15806                                matching */
15807     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
15808                                   treated more simply than the general case,
15809                                   leading to less compilation and execution
15810                                   work */
15811     UV element_count = 0;   /* Number of distinct elements in the class.
15812                                Optimizations may be possible if this is tiny */
15813     AV * multi_char_matches = NULL; /* Code points that fold to more than one
15814                                        character; used under /i */
15815     UV n;
15816     char * stop_ptr = RExC_end;    /* where to stop parsing */
15817     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
15818                                                    space? */
15819
15820     /* Unicode properties are stored in a swash; this holds the current one
15821      * being parsed.  If this swash is the only above-latin1 component of the
15822      * character class, an optimization is to pass it directly on to the
15823      * execution engine.  Otherwise, it is set to NULL to indicate that there
15824      * are other things in the class that have to be dealt with at execution
15825      * time */
15826     SV* swash = NULL;           /* Code points that match \p{} \P{} */
15827
15828     /* Set if a component of this character class is user-defined; just passed
15829      * on to the engine */
15830     bool has_user_defined_property = FALSE;
15831
15832     /* inversion list of code points this node matches only when the target
15833      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
15834      * /d) */
15835     SV* has_upper_latin1_only_utf8_matches = NULL;
15836
15837     /* Inversion list of code points this node matches regardless of things
15838      * like locale, folding, utf8ness of the target string */
15839     SV* cp_list = NULL;
15840
15841     /* Like cp_list, but code points on this list need to be checked for things
15842      * that fold to/from them under /i */
15843     SV* cp_foldable_list = NULL;
15844
15845     /* Like cp_list, but code points on this list are valid only when the
15846      * runtime locale is UTF-8 */
15847     SV* only_utf8_locale_list = NULL;
15848
15849     /* In a range, if one of the endpoints is non-character-set portable,
15850      * meaning that it hard-codes a code point that may mean a different
15851      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
15852      * mnemonic '\t' which each mean the same character no matter which
15853      * character set the platform is on. */
15854     unsigned int non_portable_endpoint = 0;
15855
15856     /* Is the range unicode? which means on a platform that isn't 1-1 native
15857      * to Unicode (i.e. non-ASCII), each code point in it should be considered
15858      * to be a Unicode value.  */
15859     bool unicode_range = FALSE;
15860     bool invert = FALSE;    /* Is this class to be complemented */
15861
15862     bool warn_super = ALWAYS_WARN_SUPER;
15863
15864     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
15865         case we need to change the emitted regop to an EXACT. */
15866     const char * orig_parse = RExC_parse;
15867     const SSize_t orig_size = RExC_size;
15868     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
15869
15870     /* This variable is used to mark where the end in the input is of something
15871      * that looks like a POSIX construct but isn't.  During the parse, when
15872      * something looks like it could be such a construct is encountered, it is
15873      * checked for being one, but not if we've already checked this area of the
15874      * input.  Only after this position is reached do we check again */
15875     char *not_posix_region_end = RExC_parse - 1;
15876
15877     AV* posix_warnings = NULL;
15878     const bool do_posix_warnings =     return_posix_warnings
15879                                    || (PASS2 && ckWARN(WARN_REGEXP));
15880
15881     GET_RE_DEBUG_FLAGS_DECL;
15882
15883     PERL_ARGS_ASSERT_REGCLASS;
15884 #ifndef DEBUGGING
15885     PERL_UNUSED_ARG(depth);
15886 #endif
15887
15888     DEBUG_PARSE("clas");
15889
15890 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
15891     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
15892                                    && UNICODE_DOT_DOT_VERSION == 0)
15893     allow_multi_folds = FALSE;
15894 #endif
15895
15896     /* Assume we are going to generate an ANYOF node. */
15897     ret = reganode(pRExC_state,
15898                    (LOC)
15899                     ? ANYOFL
15900                     : ANYOF,
15901                    0);
15902
15903     if (SIZE_ONLY) {
15904         RExC_size += ANYOF_SKIP;
15905         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
15906     }
15907     else {
15908         ANYOF_FLAGS(ret) = 0;
15909
15910         RExC_emit += ANYOF_SKIP;
15911         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
15912         initial_listsv_len = SvCUR(listsv);
15913         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
15914     }
15915
15916     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15917
15918     assert(RExC_parse <= RExC_end);
15919
15920     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
15921         RExC_parse++;
15922         invert = TRUE;
15923         allow_multi_folds = FALSE;
15924         MARK_NAUGHTY(1);
15925         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15926     }
15927
15928     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
15929     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
15930         int maybe_class = handle_possible_posix(pRExC_state,
15931                                                 RExC_parse,
15932                                                 &not_posix_region_end,
15933                                                 NULL,
15934                                                 TRUE /* checking only */);
15935         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
15936             SAVEFREESV(RExC_rx_sv);
15937             ckWARN4reg(not_posix_region_end,
15938                     "POSIX syntax [%c %c] belongs inside character classes%s",
15939                     *RExC_parse, *RExC_parse,
15940                     (maybe_class == OOB_NAMEDCLASS)
15941                     ? ((POSIXCC_NOTYET(*RExC_parse))
15942                         ? " (but this one isn't implemented)"
15943                         : " (but this one isn't fully valid)")
15944                     : ""
15945                     );
15946             (void)ReREFCNT_inc(RExC_rx_sv);
15947         }
15948     }
15949
15950     /* If the caller wants us to just parse a single element, accomplish this
15951      * by faking the loop ending condition */
15952     if (stop_at_1 && RExC_end > RExC_parse) {
15953         stop_ptr = RExC_parse + 1;
15954     }
15955
15956     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
15957     if (UCHARAT(RExC_parse) == ']')
15958         goto charclassloop;
15959
15960     while (1) {
15961
15962         if (   posix_warnings
15963             && av_tindex_nomg(posix_warnings) >= 0
15964             && RExC_parse > not_posix_region_end)
15965         {
15966             /* Warnings about posix class issues are considered tentative until
15967              * we are far enough along in the parse that we can no longer
15968              * change our mind, at which point we either output them or add
15969              * them, if it has so specified, to what gets returned to the
15970              * caller.  This is done each time through the loop so that a later
15971              * class won't zap them before they have been dealt with. */
15972             output_or_return_posix_warnings(pRExC_state, posix_warnings,
15973                                             return_posix_warnings);
15974         }
15975
15976         if  (RExC_parse >= stop_ptr) {
15977             break;
15978         }
15979
15980         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15981
15982         if  (UCHARAT(RExC_parse) == ']') {
15983             break;
15984         }
15985
15986       charclassloop:
15987
15988         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
15989         save_value = value;
15990         save_prevvalue = prevvalue;
15991
15992         if (!range) {
15993             rangebegin = RExC_parse;
15994             element_count++;
15995             non_portable_endpoint = 0;
15996         }
15997         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
15998             value = utf8n_to_uvchr((U8*)RExC_parse,
15999                                    RExC_end - RExC_parse,
16000                                    &numlen, UTF8_ALLOW_DEFAULT);
16001             RExC_parse += numlen;
16002         }
16003         else
16004             value = UCHARAT(RExC_parse++);
16005
16006         if (value == '[') {
16007             char * posix_class_end;
16008             namedclass = handle_possible_posix(pRExC_state,
16009                                                RExC_parse,
16010                                                &posix_class_end,
16011                                                do_posix_warnings ? &posix_warnings : NULL,
16012                                                FALSE    /* die if error */);
16013             if (namedclass > OOB_NAMEDCLASS) {
16014
16015                 /* If there was an earlier attempt to parse this particular
16016                  * posix class, and it failed, it was a false alarm, as this
16017                  * successful one proves */
16018                 if (   posix_warnings
16019                     && av_tindex_nomg(posix_warnings) >= 0
16020                     && not_posix_region_end >= RExC_parse
16021                     && not_posix_region_end <= posix_class_end)
16022                 {
16023                     av_undef(posix_warnings);
16024                 }
16025
16026                 RExC_parse = posix_class_end;
16027             }
16028             else if (namedclass == OOB_NAMEDCLASS) {
16029                 not_posix_region_end = posix_class_end;
16030             }
16031             else {
16032                 namedclass = OOB_NAMEDCLASS;
16033             }
16034         }
16035         else if (   RExC_parse - 1 > not_posix_region_end
16036                  && MAYBE_POSIXCC(value))
16037         {
16038             (void) handle_possible_posix(
16039                         pRExC_state,
16040                         RExC_parse - 1,  /* -1 because parse has already been
16041                                             advanced */
16042                         &not_posix_region_end,
16043                         do_posix_warnings ? &posix_warnings : NULL,
16044                         TRUE /* checking only */);
16045         }
16046         else if (value == '\\') {
16047             /* Is a backslash; get the code point of the char after it */
16048
16049             if (RExC_parse >= RExC_end) {
16050                 vFAIL("Unmatched [");
16051             }
16052
16053             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16054                 value = utf8n_to_uvchr((U8*)RExC_parse,
16055                                    RExC_end - RExC_parse,
16056                                    &numlen, UTF8_ALLOW_DEFAULT);
16057                 RExC_parse += numlen;
16058             }
16059             else
16060                 value = UCHARAT(RExC_parse++);
16061
16062             /* Some compilers cannot handle switching on 64-bit integer
16063              * values, therefore value cannot be an UV.  Yes, this will
16064              * be a problem later if we want switch on Unicode.
16065              * A similar issue a little bit later when switching on
16066              * namedclass. --jhi */
16067
16068             /* If the \ is escaping white space when white space is being
16069              * skipped, it means that that white space is wanted literally, and
16070              * is already in 'value'.  Otherwise, need to translate the escape
16071              * into what it signifies. */
16072             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16073
16074             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16075             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16076             case 's':   namedclass = ANYOF_SPACE;       break;
16077             case 'S':   namedclass = ANYOF_NSPACE;      break;
16078             case 'd':   namedclass = ANYOF_DIGIT;       break;
16079             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16080             case 'v':   namedclass = ANYOF_VERTWS;      break;
16081             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16082             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16083             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16084             case 'N':  /* Handle \N{NAME} in class */
16085                 {
16086                     const char * const backslash_N_beg = RExC_parse - 2;
16087                     int cp_count;
16088
16089                     if (! grok_bslash_N(pRExC_state,
16090                                         NULL,      /* No regnode */
16091                                         &value,    /* Yes single value */
16092                                         &cp_count, /* Multiple code pt count */
16093                                         flagp,
16094                                         strict,
16095                                         depth)
16096                     ) {
16097
16098                         if (*flagp & NEED_UTF8)
16099                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16100                         if (*flagp & RESTART_PASS1)
16101                             return NULL;
16102
16103                         if (cp_count < 0) {
16104                             vFAIL("\\N in a character class must be a named character: \\N{...}");
16105                         }
16106                         else if (cp_count == 0) {
16107                             if (PASS2) {
16108                                 ckWARNreg(RExC_parse,
16109                                         "Ignoring zero length \\N{} in character class");
16110                             }
16111                         }
16112                         else { /* cp_count > 1 */
16113                             if (! RExC_in_multi_char_class) {
16114                                 if (invert || range || *RExC_parse == '-') {
16115                                     if (strict) {
16116                                         RExC_parse--;
16117                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
16118                                     }
16119                                     else if (PASS2) {
16120                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
16121                                     }
16122                                     break; /* <value> contains the first code
16123                                               point. Drop out of the switch to
16124                                               process it */
16125                                 }
16126                                 else {
16127                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
16128                                                  RExC_parse - backslash_N_beg);
16129                                     multi_char_matches
16130                                         = add_multi_match(multi_char_matches,
16131                                                           multi_char_N,
16132                                                           cp_count);
16133                                 }
16134                             }
16135                         } /* End of cp_count != 1 */
16136
16137                         /* This element should not be processed further in this
16138                          * class */
16139                         element_count--;
16140                         value = save_value;
16141                         prevvalue = save_prevvalue;
16142                         continue;   /* Back to top of loop to get next char */
16143                     }
16144
16145                     /* Here, is a single code point, and <value> contains it */
16146                     unicode_range = TRUE;   /* \N{} are Unicode */
16147                 }
16148                 break;
16149             case 'p':
16150             case 'P':
16151                 {
16152                 char *e;
16153
16154                 /* We will handle any undefined properties ourselves */
16155                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
16156                                        /* And we actually would prefer to get
16157                                         * the straight inversion list of the
16158                                         * swash, since we will be accessing it
16159                                         * anyway, to save a little time */
16160                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
16161
16162                 if (RExC_parse >= RExC_end)
16163                     vFAIL2("Empty \\%c", (U8)value);
16164                 if (*RExC_parse == '{') {
16165                     const U8 c = (U8)value;
16166                     e = strchr(RExC_parse, '}');
16167                     if (!e) {
16168                         RExC_parse++;
16169                         vFAIL2("Missing right brace on \\%c{}", c);
16170                     }
16171
16172                     RExC_parse++;
16173                     while (isSPACE(*RExC_parse)) {
16174                          RExC_parse++;
16175                     }
16176
16177                     if (UCHARAT(RExC_parse) == '^') {
16178
16179                         /* toggle.  (The rhs xor gets the single bit that
16180                          * differs between P and p; the other xor inverts just
16181                          * that bit) */
16182                         value ^= 'P' ^ 'p';
16183
16184                         RExC_parse++;
16185                         while (isSPACE(*RExC_parse)) {
16186                             RExC_parse++;
16187                         }
16188                     }
16189
16190                     if (e == RExC_parse)
16191                         vFAIL2("Empty \\%c{}", c);
16192
16193                     n = e - RExC_parse;
16194                     while (isSPACE(*(RExC_parse + n - 1)))
16195                         n--;
16196                 }   /* The \p isn't immediately followed by a '{' */
16197                 else if (! isALPHA(*RExC_parse)) {
16198                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16199                     vFAIL2("Character following \\%c must be '{' or a "
16200                            "single-character Unicode property name",
16201                            (U8) value);
16202                 }
16203                 else {
16204                     e = RExC_parse;
16205                     n = 1;
16206                 }
16207                 if (!SIZE_ONLY) {
16208                     SV* invlist;
16209                     char* name;
16210                     char* base_name;    /* name after any packages are stripped */
16211                     char* lookup_name = NULL;
16212                     const char * const colon_colon = "::";
16213
16214                     /* Try to get the definition of the property into
16215                      * <invlist>.  If /i is in effect, the effective property
16216                      * will have its name be <__NAME_i>.  The design is
16217                      * discussed in commit
16218                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
16219                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
16220                     SAVEFREEPV(name);
16221                     if (FOLD) {
16222                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
16223
16224                         /* The function call just below that uses this can fail
16225                          * to return, leaking memory if we don't do this */
16226                         SAVEFREEPV(lookup_name);
16227                     }
16228
16229                     /* Look up the property name, and get its swash and
16230                      * inversion list, if the property is found  */
16231                     SvREFCNT_dec(swash); /* Free any left-overs */
16232                     swash = _core_swash_init("utf8",
16233                                              (lookup_name)
16234                                               ? lookup_name
16235                                               : name,
16236                                              &PL_sv_undef,
16237                                              1, /* binary */
16238                                              0, /* not tr/// */
16239                                              NULL, /* No inversion list */
16240                                              &swash_init_flags
16241                                             );
16242                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
16243                         HV* curpkg = (IN_PERL_COMPILETIME)
16244                                       ? PL_curstash
16245                                       : CopSTASH(PL_curcop);
16246                         UV final_n = n;
16247                         bool has_pkg;
16248
16249                         if (swash) {    /* Got a swash but no inversion list.
16250                                            Something is likely wrong that will
16251                                            be sorted-out later */
16252                             SvREFCNT_dec_NN(swash);
16253                             swash = NULL;
16254                         }
16255
16256                         /* Here didn't find it.  It could be a an error (like a
16257                          * typo) in specifying a Unicode property, or it could
16258                          * be a user-defined property that will be available at
16259                          * run-time.  The names of these must begin with 'In'
16260                          * or 'Is' (after any packages are stripped off).  So
16261                          * if not one of those, or if we accept only
16262                          * compile-time properties, is an error; otherwise add
16263                          * it to the list for run-time look up. */
16264                         if ((base_name = rninstr(name, name + n,
16265                                                  colon_colon, colon_colon + 2)))
16266                         { /* Has ::.  We know this must be a user-defined
16267                              property */
16268                             base_name += 2;
16269                             final_n -= base_name - name;
16270                             has_pkg = TRUE;
16271                         }
16272                         else {
16273                             base_name = name;
16274                             has_pkg = FALSE;
16275                         }
16276
16277                         if (   final_n < 3
16278                             || base_name[0] != 'I'
16279                             || (base_name[1] != 's' && base_name[1] != 'n')
16280                             || ret_invlist)
16281                         {
16282                             const char * const msg
16283                                 = (has_pkg)
16284                                   ? "Illegal user-defined property name"
16285                                   : "Can't find Unicode property definition";
16286                             RExC_parse = e + 1;
16287
16288                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16289                             vFAIL3utf8f("%s \"%" UTF8f "\"",
16290                                 msg, UTF8fARG(UTF, n, name));
16291                         }
16292
16293                         /* If the property name doesn't already have a package
16294                          * name, add the current one to it so that it can be
16295                          * referred to outside it. [perl #121777] */
16296                         if (! has_pkg && curpkg) {
16297                             char* pkgname = HvNAME(curpkg);
16298                             if (strNE(pkgname, "main")) {
16299                                 char* full_name = Perl_form(aTHX_
16300                                                             "%s::%s",
16301                                                             pkgname,
16302                                                             name);
16303                                 n = strlen(full_name);
16304                                 name = savepvn(full_name, n);
16305                                 SAVEFREEPV(name);
16306                             }
16307                         }
16308                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
16309                                         (value == 'p' ? '+' : '!'),
16310                                         (FOLD) ? "__" : "",
16311                                         UTF8fARG(UTF, n, name),
16312                                         (FOLD) ? "_i" : "");
16313                         has_user_defined_property = TRUE;
16314                         optimizable = FALSE;    /* Will have to leave this an
16315                                                    ANYOF node */
16316
16317                         /* We don't know yet what this matches, so have to flag
16318                          * it */
16319                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16320                     }
16321                     else {
16322
16323                         /* Here, did get the swash and its inversion list.  If
16324                          * the swash is from a user-defined property, then this
16325                          * whole character class should be regarded as such */
16326                         if (swash_init_flags
16327                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16328                         {
16329                             has_user_defined_property = TRUE;
16330                         }
16331                         else if
16332                             /* We warn on matching an above-Unicode code point
16333                              * if the match would return true, except don't
16334                              * warn for \p{All}, which has exactly one element
16335                              * = 0 */
16336                             (_invlist_contains_cp(invlist, 0x110000)
16337                                 && (! (_invlist_len(invlist) == 1
16338                                        && *invlist_array(invlist) == 0)))
16339                         {
16340                             warn_super = TRUE;
16341                         }
16342
16343
16344                         /* Invert if asking for the complement */
16345                         if (value == 'P') {
16346                             _invlist_union_complement_2nd(properties,
16347                                                           invlist,
16348                                                           &properties);
16349
16350                             /* The swash can't be used as-is, because we've
16351                              * inverted things; delay removing it to here after
16352                              * have copied its invlist above */
16353                             SvREFCNT_dec_NN(swash);
16354                             swash = NULL;
16355                         }
16356                         else {
16357                             _invlist_union(properties, invlist, &properties);
16358                         }
16359                     }
16360                 }
16361                 RExC_parse = e + 1;
16362                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16363                                                 named */
16364
16365                 /* \p means they want Unicode semantics */
16366                 REQUIRE_UNI_RULES(flagp, NULL);
16367                 }
16368                 break;
16369             case 'n':   value = '\n';                   break;
16370             case 'r':   value = '\r';                   break;
16371             case 't':   value = '\t';                   break;
16372             case 'f':   value = '\f';                   break;
16373             case 'b':   value = '\b';                   break;
16374             case 'e':   value = ESC_NATIVE;             break;
16375             case 'a':   value = '\a';                   break;
16376             case 'o':
16377                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16378                 {
16379                     const char* error_msg;
16380                     bool valid = grok_bslash_o(&RExC_parse,
16381                                                &value,
16382                                                &error_msg,
16383                                                PASS2,   /* warnings only in
16384                                                            pass 2 */
16385                                                strict,
16386                                                silence_non_portable,
16387                                                UTF);
16388                     if (! valid) {
16389                         vFAIL(error_msg);
16390                     }
16391                 }
16392                 non_portable_endpoint++;
16393                 break;
16394             case 'x':
16395                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16396                 {
16397                     const char* error_msg;
16398                     bool valid = grok_bslash_x(&RExC_parse,
16399                                                &value,
16400                                                &error_msg,
16401                                                PASS2, /* Output warnings */
16402                                                strict,
16403                                                silence_non_portable,
16404                                                UTF);
16405                     if (! valid) {
16406                         vFAIL(error_msg);
16407                     }
16408                 }
16409                 non_portable_endpoint++;
16410                 break;
16411             case 'c':
16412                 value = grok_bslash_c(*RExC_parse++, PASS2);
16413                 non_portable_endpoint++;
16414                 break;
16415             case '0': case '1': case '2': case '3': case '4':
16416             case '5': case '6': case '7':
16417                 {
16418                     /* Take 1-3 octal digits */
16419                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16420                     numlen = (strict) ? 4 : 3;
16421                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16422                     RExC_parse += numlen;
16423                     if (numlen != 3) {
16424                         if (strict) {
16425                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16426                             vFAIL("Need exactly 3 octal digits");
16427                         }
16428                         else if (! SIZE_ONLY /* like \08, \178 */
16429                                  && numlen < 3
16430                                  && RExC_parse < RExC_end
16431                                  && isDIGIT(*RExC_parse)
16432                                  && ckWARN(WARN_REGEXP))
16433                         {
16434                             SAVEFREESV(RExC_rx_sv);
16435                             reg_warn_non_literal_string(
16436                                  RExC_parse + 1,
16437                                  form_short_octal_warning(RExC_parse, numlen));
16438                             (void)ReREFCNT_inc(RExC_rx_sv);
16439                         }
16440                     }
16441                     non_portable_endpoint++;
16442                     break;
16443                 }
16444             default:
16445                 /* Allow \_ to not give an error */
16446                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16447                     if (strict) {
16448                         vFAIL2("Unrecognized escape \\%c in character class",
16449                                (int)value);
16450                     }
16451                     else {
16452                         SAVEFREESV(RExC_rx_sv);
16453                         ckWARN2reg(RExC_parse,
16454                             "Unrecognized escape \\%c in character class passed through",
16455                             (int)value);
16456                         (void)ReREFCNT_inc(RExC_rx_sv);
16457                     }
16458                 }
16459                 break;
16460             }   /* End of switch on char following backslash */
16461         } /* end of handling backslash escape sequences */
16462
16463         /* Here, we have the current token in 'value' */
16464
16465         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
16466             U8 classnum;
16467
16468             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
16469              * literal, as is the character that began the false range, i.e.
16470              * the 'a' in the examples */
16471             if (range) {
16472                 if (!SIZE_ONLY) {
16473                     const int w = (RExC_parse >= rangebegin)
16474                                   ? RExC_parse - rangebegin
16475                                   : 0;
16476                     if (strict) {
16477                         vFAIL2utf8f(
16478                             "False [] range \"%" UTF8f "\"",
16479                             UTF8fARG(UTF, w, rangebegin));
16480                     }
16481                     else {
16482                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
16483                         ckWARN2reg(RExC_parse,
16484                             "False [] range \"%" UTF8f "\"",
16485                             UTF8fARG(UTF, w, rangebegin));
16486                         (void)ReREFCNT_inc(RExC_rx_sv);
16487                         cp_list = add_cp_to_invlist(cp_list, '-');
16488                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
16489                                                              prevvalue);
16490                     }
16491                 }
16492
16493                 range = 0; /* this was not a true range */
16494                 element_count += 2; /* So counts for three values */
16495             }
16496
16497             classnum = namedclass_to_classnum(namedclass);
16498
16499             if (LOC && namedclass < ANYOF_POSIXL_MAX
16500 #ifndef HAS_ISASCII
16501                 && classnum != _CC_ASCII
16502 #endif
16503             ) {
16504                 /* What the Posix classes (like \w, [:space:]) match in locale
16505                  * isn't knowable under locale until actual match time.  Room
16506                  * must be reserved (one time per outer bracketed class) to
16507                  * store such classes.  The space will contain a bit for each
16508                  * named class that is to be matched against.  This isn't
16509                  * needed for \p{} and pseudo-classes, as they are not affected
16510                  * by locale, and hence are dealt with separately */
16511                 if (! need_class) {
16512                     need_class = 1;
16513                     if (SIZE_ONLY) {
16514                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16515                     }
16516                     else {
16517                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16518                     }
16519                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
16520                     ANYOF_POSIXL_ZERO(ret);
16521
16522                     /* We can't change this into some other type of node
16523                      * (unless this is the only element, in which case there
16524                      * are nodes that mean exactly this) as has runtime
16525                      * dependencies */
16526                     optimizable = FALSE;
16527                 }
16528
16529                 /* Coverity thinks it is possible for this to be negative; both
16530                  * jhi and khw think it's not, but be safer */
16531                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16532                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
16533
16534                 /* See if it already matches the complement of this POSIX
16535                  * class */
16536                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16537                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
16538                                                             ? -1
16539                                                             : 1)))
16540                 {
16541                     posixl_matches_all = TRUE;
16542                     break;  /* No need to continue.  Since it matches both
16543                                e.g., \w and \W, it matches everything, and the
16544                                bracketed class can be optimized into qr/./s */
16545                 }
16546
16547                 /* Add this class to those that should be checked at runtime */
16548                 ANYOF_POSIXL_SET(ret, namedclass);
16549
16550                 /* The above-Latin1 characters are not subject to locale rules.
16551                  * Just add them, in the second pass, to the
16552                  * unconditionally-matched list */
16553                 if (! SIZE_ONLY) {
16554                     SV* scratch_list = NULL;
16555
16556                     /* Get the list of the above-Latin1 code points this
16557                      * matches */
16558                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
16559                                           PL_XPosix_ptrs[classnum],
16560
16561                                           /* Odd numbers are complements, like
16562                                            * NDIGIT, NASCII, ... */
16563                                           namedclass % 2 != 0,
16564                                           &scratch_list);
16565                     /* Checking if 'cp_list' is NULL first saves an extra
16566                      * clone.  Its reference count will be decremented at the
16567                      * next union, etc, or if this is the only instance, at the
16568                      * end of the routine */
16569                     if (! cp_list) {
16570                         cp_list = scratch_list;
16571                     }
16572                     else {
16573                         _invlist_union(cp_list, scratch_list, &cp_list);
16574                         SvREFCNT_dec_NN(scratch_list);
16575                     }
16576                     continue;   /* Go get next character */
16577                 }
16578             }
16579             else if (! SIZE_ONLY) {
16580
16581                 /* Here, not in pass1 (in that pass we skip calculating the
16582                  * contents of this class), and is not /l, or is a POSIX class
16583                  * for which /l doesn't matter (or is a Unicode property, which
16584                  * is skipped here). */
16585                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
16586                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
16587
16588                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
16589                          * nor /l make a difference in what these match,
16590                          * therefore we just add what they match to cp_list. */
16591                         if (classnum != _CC_VERTSPACE) {
16592                             assert(   namedclass == ANYOF_HORIZWS
16593                                    || namedclass == ANYOF_NHORIZWS);
16594
16595                             /* It turns out that \h is just a synonym for
16596                              * XPosixBlank */
16597                             classnum = _CC_BLANK;
16598                         }
16599
16600                         _invlist_union_maybe_complement_2nd(
16601                                 cp_list,
16602                                 PL_XPosix_ptrs[classnum],
16603                                 namedclass % 2 != 0,    /* Complement if odd
16604                                                           (NHORIZWS, NVERTWS)
16605                                                         */
16606                                 &cp_list);
16607                     }
16608                 }
16609                 else if (  UNI_SEMANTICS
16610                         || classnum == _CC_ASCII
16611                         || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
16612                                                   || classnum == _CC_XDIGIT)))
16613                 {
16614                     /* We usually have to worry about /d and /a affecting what
16615                      * POSIX classes match, with special code needed for /d
16616                      * because we won't know until runtime what all matches.
16617                      * But there is no extra work needed under /u, and
16618                      * [:ascii:] is unaffected by /a and /d; and :digit: and
16619                      * :xdigit: don't have runtime differences under /d.  So we
16620                      * can special case these, and avoid some extra work below,
16621                      * and at runtime. */
16622                     _invlist_union_maybe_complement_2nd(
16623                                                      simple_posixes,
16624                                                      PL_XPosix_ptrs[classnum],
16625                                                      namedclass % 2 != 0,
16626                                                      &simple_posixes);
16627                 }
16628                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
16629                            complement and use nposixes */
16630                     SV** posixes_ptr = namedclass % 2 == 0
16631                                        ? &posixes
16632                                        : &nposixes;
16633                     _invlist_union_maybe_complement_2nd(
16634                                                      *posixes_ptr,
16635                                                      PL_XPosix_ptrs[classnum],
16636                                                      namedclass % 2 != 0,
16637                                                      posixes_ptr);
16638                 }
16639             }
16640         } /* end of namedclass \blah */
16641
16642         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16643
16644         /* If 'range' is set, 'value' is the ending of a range--check its
16645          * validity.  (If value isn't a single code point in the case of a
16646          * range, we should have figured that out above in the code that
16647          * catches false ranges).  Later, we will handle each individual code
16648          * point in the range.  If 'range' isn't set, this could be the
16649          * beginning of a range, so check for that by looking ahead to see if
16650          * the next real character to be processed is the range indicator--the
16651          * minus sign */
16652
16653         if (range) {
16654 #ifdef EBCDIC
16655             /* For unicode ranges, we have to test that the Unicode as opposed
16656              * to the native values are not decreasing.  (Above 255, there is
16657              * no difference between native and Unicode) */
16658             if (unicode_range && prevvalue < 255 && value < 255) {
16659                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
16660                     goto backwards_range;
16661                 }
16662             }
16663             else
16664 #endif
16665             if (prevvalue > value) /* b-a */ {
16666                 int w;
16667 #ifdef EBCDIC
16668               backwards_range:
16669 #endif
16670                 w = RExC_parse - rangebegin;
16671                 vFAIL2utf8f(
16672                     "Invalid [] range \"%" UTF8f "\"",
16673                     UTF8fARG(UTF, w, rangebegin));
16674                 NOT_REACHED; /* NOTREACHED */
16675             }
16676         }
16677         else {
16678             prevvalue = value; /* save the beginning of the potential range */
16679             if (! stop_at_1     /* Can't be a range if parsing just one thing */
16680                 && *RExC_parse == '-')
16681             {
16682                 char* next_char_ptr = RExC_parse + 1;
16683
16684                 /* Get the next real char after the '-' */
16685                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
16686
16687                 /* If the '-' is at the end of the class (just before the ']',
16688                  * it is a literal minus; otherwise it is a range */
16689                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
16690                     RExC_parse = next_char_ptr;
16691
16692                     /* a bad range like \w-, [:word:]- ? */
16693                     if (namedclass > OOB_NAMEDCLASS) {
16694                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
16695                             const int w = RExC_parse >= rangebegin
16696                                           ?  RExC_parse - rangebegin
16697                                           : 0;
16698                             if (strict) {
16699                                 vFAIL4("False [] range \"%*.*s\"",
16700                                     w, w, rangebegin);
16701                             }
16702                             else if (PASS2) {
16703                                 vWARN4(RExC_parse,
16704                                     "False [] range \"%*.*s\"",
16705                                     w, w, rangebegin);
16706                             }
16707                         }
16708                         if (!SIZE_ONLY) {
16709                             cp_list = add_cp_to_invlist(cp_list, '-');
16710                         }
16711                         element_count++;
16712                     } else
16713                         range = 1;      /* yeah, it's a range! */
16714                     continue;   /* but do it the next time */
16715                 }
16716             }
16717         }
16718
16719         if (namedclass > OOB_NAMEDCLASS) {
16720             continue;
16721         }
16722
16723         /* Here, we have a single value this time through the loop, and
16724          * <prevvalue> is the beginning of the range, if any; or <value> if
16725          * not. */
16726
16727         /* non-Latin1 code point implies unicode semantics.  Must be set in
16728          * pass1 so is there for the whole of pass 2 */
16729         if (value > 255) {
16730             REQUIRE_UNI_RULES(flagp, NULL);
16731         }
16732
16733         /* Ready to process either the single value, or the completed range.
16734          * For single-valued non-inverted ranges, we consider the possibility
16735          * of multi-char folds.  (We made a conscious decision to not do this
16736          * for the other cases because it can often lead to non-intuitive
16737          * results.  For example, you have the peculiar case that:
16738          *  "s s" =~ /^[^\xDF]+$/i => Y
16739          *  "ss"  =~ /^[^\xDF]+$/i => N
16740          *
16741          * See [perl #89750] */
16742         if (FOLD && allow_multi_folds && value == prevvalue) {
16743             if (value == LATIN_SMALL_LETTER_SHARP_S
16744                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
16745                                                         value)))
16746             {
16747                 /* Here <value> is indeed a multi-char fold.  Get what it is */
16748
16749                 U8 foldbuf[UTF8_MAXBYTES_CASE];
16750                 STRLEN foldlen;
16751
16752                 UV folded = _to_uni_fold_flags(
16753                                 value,
16754                                 foldbuf,
16755                                 &foldlen,
16756                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
16757                                                    ? FOLD_FLAGS_NOMIX_ASCII
16758                                                    : 0)
16759                                 );
16760
16761                 /* Here, <folded> should be the first character of the
16762                  * multi-char fold of <value>, with <foldbuf> containing the
16763                  * whole thing.  But, if this fold is not allowed (because of
16764                  * the flags), <fold> will be the same as <value>, and should
16765                  * be processed like any other character, so skip the special
16766                  * handling */
16767                 if (folded != value) {
16768
16769                     /* Skip if we are recursed, currently parsing the class
16770                      * again.  Otherwise add this character to the list of
16771                      * multi-char folds. */
16772                     if (! RExC_in_multi_char_class) {
16773                         STRLEN cp_count = utf8_length(foldbuf,
16774                                                       foldbuf + foldlen);
16775                         SV* multi_fold = sv_2mortal(newSVpvs(""));
16776
16777                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
16778
16779                         multi_char_matches
16780                                         = add_multi_match(multi_char_matches,
16781                                                           multi_fold,
16782                                                           cp_count);
16783
16784                     }
16785
16786                     /* This element should not be processed further in this
16787                      * class */
16788                     element_count--;
16789                     value = save_value;
16790                     prevvalue = save_prevvalue;
16791                     continue;
16792                 }
16793             }
16794         }
16795
16796         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
16797             if (range) {
16798
16799                 /* If the range starts above 255, everything is portable and
16800                  * likely to be so for any forseeable character set, so don't
16801                  * warn. */
16802                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
16803                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
16804                 }
16805                 else if (prevvalue != value) {
16806
16807                     /* Under strict, ranges that stop and/or end in an ASCII
16808                      * printable should have each end point be a portable value
16809                      * for it (preferably like 'A', but we don't warn if it is
16810                      * a (portable) Unicode name or code point), and the range
16811                      * must be be all digits or all letters of the same case.
16812                      * Otherwise, the range is non-portable and unclear as to
16813                      * what it contains */
16814                     if ((isPRINT_A(prevvalue) || isPRINT_A(value))
16815                         && (non_portable_endpoint
16816                             || ! ((isDIGIT_A(prevvalue) && isDIGIT_A(value))
16817                                    || (isLOWER_A(prevvalue) && isLOWER_A(value))
16818                                    || (isUPPER_A(prevvalue) && isUPPER_A(value)))))
16819                     {
16820                         vWARN(RExC_parse, "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\"");
16821                     }
16822                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
16823
16824                         /* But the nature of Unicode and languages mean we
16825                          * can't do the same checks for above-ASCII ranges,
16826                          * except in the case of digit ones.  These should
16827                          * contain only digits from the same group of 10.  The
16828                          * ASCII case is handled just above.  0x660 is the
16829                          * first digit character beyond ASCII.  Hence here, the
16830                          * range could be a range of digits.  Find out.  */
16831                         IV index_start = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16832                                                          prevvalue);
16833                         IV index_final = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16834                                                          value);
16835
16836                         /* If the range start and final points are in the same
16837                          * inversion list element, it means that either both
16838                          * are not digits, or both are digits in a consecutive
16839                          * sequence of digits.  (So far, Unicode has kept all
16840                          * such sequences as distinct groups of 10, but assert
16841                          * to make sure).  If the end points are not in the
16842                          * same element, neither should be a digit. */
16843                         if (index_start == index_final) {
16844                             assert(! ELEMENT_RANGE_MATCHES_INVLIST(index_start)
16845                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16846                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16847                                == 10)
16848                                /* But actually Unicode did have one group of 11
16849                                 * 'digits' in 5.2, so in case we are operating
16850                                 * on that version, let that pass */
16851                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16852                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16853                                 == 11
16854                                && invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16855                                 == 0x19D0)
16856                             );
16857                         }
16858                         else if ((index_start >= 0
16859                                   && ELEMENT_RANGE_MATCHES_INVLIST(index_start))
16860                                  || (index_final >= 0
16861                                      && ELEMENT_RANGE_MATCHES_INVLIST(index_final)))
16862                         {
16863                             vWARN(RExC_parse, "Ranges of digits should be from the same group of 10");
16864                         }
16865                     }
16866                 }
16867             }
16868             if ((! range || prevvalue == value) && non_portable_endpoint) {
16869                 if (isPRINT_A(value)) {
16870                     char literal[3];
16871                     unsigned d = 0;
16872                     if (isBACKSLASHED_PUNCT(value)) {
16873                         literal[d++] = '\\';
16874                     }
16875                     literal[d++] = (char) value;
16876                     literal[d++] = '\0';
16877
16878                     vWARN4(RExC_parse,
16879                            "\"%.*s\" is more clearly written simply as \"%s\"",
16880                            (int) (RExC_parse - rangebegin),
16881                            rangebegin,
16882                            literal
16883                         );
16884                 }
16885                 else if isMNEMONIC_CNTRL(value) {
16886                     vWARN4(RExC_parse,
16887                            "\"%.*s\" is more clearly written simply as \"%s\"",
16888                            (int) (RExC_parse - rangebegin),
16889                            rangebegin,
16890                            cntrl_to_mnemonic((U8) value)
16891                         );
16892                 }
16893             }
16894         }
16895
16896         /* Deal with this element of the class */
16897         if (! SIZE_ONLY) {
16898
16899 #ifndef EBCDIC
16900             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16901                                                      prevvalue, value);
16902 #else
16903             /* On non-ASCII platforms, for ranges that span all of 0..255, and
16904              * ones that don't require special handling, we can just add the
16905              * range like we do for ASCII platforms */
16906             if ((UNLIKELY(prevvalue == 0) && value >= 255)
16907                 || ! (prevvalue < 256
16908                       && (unicode_range
16909                           || (! non_portable_endpoint
16910                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
16911                                   || (isUPPER_A(prevvalue)
16912                                       && isUPPER_A(value)))))))
16913             {
16914                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16915                                                          prevvalue, value);
16916             }
16917             else {
16918                 /* Here, requires special handling.  This can be because it is
16919                  * a range whose code points are considered to be Unicode, and
16920                  * so must be individually translated into native, or because
16921                  * its a subrange of 'A-Z' or 'a-z' which each aren't
16922                  * contiguous in EBCDIC, but we have defined them to include
16923                  * only the "expected" upper or lower case ASCII alphabetics.
16924                  * Subranges above 255 are the same in native and Unicode, so
16925                  * can be added as a range */
16926                 U8 start = NATIVE_TO_LATIN1(prevvalue);
16927                 unsigned j;
16928                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
16929                 for (j = start; j <= end; j++) {
16930                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
16931                 }
16932                 if (value > 255) {
16933                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16934                                                              256, value);
16935                 }
16936             }
16937 #endif
16938         }
16939
16940         range = 0; /* this range (if it was one) is done now */
16941     } /* End of loop through all the text within the brackets */
16942
16943
16944     if (   posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
16945         output_or_return_posix_warnings(pRExC_state, posix_warnings,
16946                                         return_posix_warnings);
16947     }
16948
16949     /* If anything in the class expands to more than one character, we have to
16950      * deal with them by building up a substitute parse string, and recursively
16951      * calling reg() on it, instead of proceeding */
16952     if (multi_char_matches) {
16953         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
16954         I32 cp_count;
16955         STRLEN len;
16956         char *save_end = RExC_end;
16957         char *save_parse = RExC_parse;
16958         char *save_start = RExC_start;
16959         STRLEN prefix_end = 0;      /* We copy the character class after a
16960                                        prefix supplied here.  This is the size
16961                                        + 1 of that prefix */
16962         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
16963                                        a "|" */
16964         I32 reg_flags;
16965
16966         assert(! invert);
16967         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
16968
16969 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
16970            because too confusing */
16971         if (invert) {
16972             sv_catpv(substitute_parse, "(?:");
16973         }
16974 #endif
16975
16976         /* Look at the longest folds first */
16977         for (cp_count = av_tindex_nomg(multi_char_matches);
16978                         cp_count > 0;
16979                         cp_count--)
16980         {
16981
16982             if (av_exists(multi_char_matches, cp_count)) {
16983                 AV** this_array_ptr;
16984                 SV* this_sequence;
16985
16986                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
16987                                                  cp_count, FALSE);
16988                 while ((this_sequence = av_pop(*this_array_ptr)) !=
16989                                                                 &PL_sv_undef)
16990                 {
16991                     if (! first_time) {
16992                         sv_catpv(substitute_parse, "|");
16993                     }
16994                     first_time = FALSE;
16995
16996                     sv_catpv(substitute_parse, SvPVX(this_sequence));
16997                 }
16998             }
16999         }
17000
17001         /* If the character class contains anything else besides these
17002          * multi-character folds, have to include it in recursive parsing */
17003         if (element_count) {
17004             sv_catpv(substitute_parse, "|[");
17005             prefix_end = SvCUR(substitute_parse);
17006             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17007
17008             /* Put in a closing ']' only if not going off the end, as otherwise
17009              * we are adding something that really isn't there */
17010             if (RExC_parse < RExC_end) {
17011                 sv_catpv(substitute_parse, "]");
17012             }
17013         }
17014
17015         sv_catpv(substitute_parse, ")");
17016 #if 0
17017         if (invert) {
17018             /* This is a way to get the parse to skip forward a whole named
17019              * sequence instead of matching the 2nd character when it fails the
17020              * first */
17021             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17022         }
17023 #endif
17024
17025         /* Set up the data structure so that any errors will be properly
17026          * reported.  See the comments at the definition of
17027          * REPORT_LOCATION_ARGS for details */
17028         RExC_precomp_adj = orig_parse - RExC_precomp;
17029         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
17030         RExC_adjusted_start = RExC_start + prefix_end;
17031         RExC_end = RExC_parse + len;
17032         RExC_in_multi_char_class = 1;
17033         RExC_override_recoding = 1;
17034         RExC_emit = (regnode *)orig_emit;
17035
17036         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17037
17038         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
17039
17040         /* And restore so can parse the rest of the pattern */
17041         RExC_parse = save_parse;
17042         RExC_start = RExC_adjusted_start = save_start;
17043         RExC_precomp_adj = 0;
17044         RExC_end = save_end;
17045         RExC_in_multi_char_class = 0;
17046         RExC_override_recoding = 0;
17047         SvREFCNT_dec_NN(multi_char_matches);
17048         return ret;
17049     }
17050
17051     /* Here, we've gone through the entire class and dealt with multi-char
17052      * folds.  We are now in a position that we can do some checks to see if we
17053      * can optimize this ANYOF node into a simpler one, even in Pass 1.
17054      * Currently we only do two checks:
17055      * 1) is in the unlikely event that the user has specified both, eg. \w and
17056      *    \W under /l, then the class matches everything.  (This optimization
17057      *    is done only to make the optimizer code run later work.)
17058      * 2) if the character class contains only a single element (including a
17059      *    single range), we see if there is an equivalent node for it.
17060      * Other checks are possible */
17061     if (   optimizable
17062         && ! ret_invlist   /* Can't optimize if returning the constructed
17063                               inversion list */
17064         && (UNLIKELY(posixl_matches_all) || element_count == 1))
17065     {
17066         U8 op = END;
17067         U8 arg = 0;
17068
17069         if (UNLIKELY(posixl_matches_all)) {
17070             op = SANY;
17071         }
17072         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
17073                                                    class, like \w or [:digit:]
17074                                                    or \p{foo} */
17075
17076             /* All named classes are mapped into POSIXish nodes, with its FLAG
17077              * argument giving which class it is */
17078             switch ((I32)namedclass) {
17079                 case ANYOF_UNIPROP:
17080                     break;
17081
17082                 /* These don't depend on the charset modifiers.  They always
17083                  * match under /u rules */
17084                 case ANYOF_NHORIZWS:
17085                 case ANYOF_HORIZWS:
17086                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
17087                     /* FALLTHROUGH */
17088
17089                 case ANYOF_NVERTWS:
17090                 case ANYOF_VERTWS:
17091                     op = POSIXU;
17092                     goto join_posix;
17093
17094                 /* The actual POSIXish node for all the rest depends on the
17095                  * charset modifier.  The ones in the first set depend only on
17096                  * ASCII or, if available on this platform, also locale */
17097                 case ANYOF_ASCII:
17098                 case ANYOF_NASCII:
17099 #ifdef HAS_ISASCII
17100                     op = (LOC) ? POSIXL : POSIXA;
17101 #else
17102                     op = POSIXA;
17103 #endif
17104                     goto join_posix;
17105
17106                 /* The following don't have any matches in the upper Latin1
17107                  * range, hence /d is equivalent to /u for them.  Making it /u
17108                  * saves some branches at runtime */
17109                 case ANYOF_DIGIT:
17110                 case ANYOF_NDIGIT:
17111                 case ANYOF_XDIGIT:
17112                 case ANYOF_NXDIGIT:
17113                     if (! DEPENDS_SEMANTICS) {
17114                         goto treat_as_default;
17115                     }
17116
17117                     op = POSIXU;
17118                     goto join_posix;
17119
17120                 /* The following change to CASED under /i */
17121                 case ANYOF_LOWER:
17122                 case ANYOF_NLOWER:
17123                 case ANYOF_UPPER:
17124                 case ANYOF_NUPPER:
17125                     if (FOLD) {
17126                         namedclass = ANYOF_CASED + (namedclass % 2);
17127                     }
17128                     /* FALLTHROUGH */
17129
17130                 /* The rest have more possibilities depending on the charset.
17131                  * We take advantage of the enum ordering of the charset
17132                  * modifiers to get the exact node type, */
17133                 default:
17134                   treat_as_default:
17135                     op = POSIXD + get_regex_charset(RExC_flags);
17136                     if (op > POSIXA) { /* /aa is same as /a */
17137                         op = POSIXA;
17138                     }
17139
17140                   join_posix:
17141                     /* The odd numbered ones are the complements of the
17142                      * next-lower even number one */
17143                     if (namedclass % 2 == 1) {
17144                         invert = ! invert;
17145                         namedclass--;
17146                     }
17147                     arg = namedclass_to_classnum(namedclass);
17148                     break;
17149             }
17150         }
17151         else if (value == prevvalue) {
17152
17153             /* Here, the class consists of just a single code point */
17154
17155             if (invert) {
17156                 if (! LOC && value == '\n') {
17157                     op = REG_ANY; /* Optimize [^\n] */
17158                     *flagp |= HASWIDTH|SIMPLE;
17159                     MARK_NAUGHTY(1);
17160                 }
17161             }
17162             else if (value < 256 || UTF) {
17163
17164                 /* Optimize a single value into an EXACTish node, but not if it
17165                  * would require converting the pattern to UTF-8. */
17166                 op = compute_EXACTish(pRExC_state);
17167             }
17168         } /* Otherwise is a range */
17169         else if (! LOC) {   /* locale could vary these */
17170             if (prevvalue == '0') {
17171                 if (value == '9') {
17172                     arg = _CC_DIGIT;
17173                     op = POSIXA;
17174                 }
17175             }
17176             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
17177                 /* We can optimize A-Z or a-z, but not if they could match
17178                  * something like the KELVIN SIGN under /i. */
17179                 if (prevvalue == 'A') {
17180                     if (value == 'Z'
17181 #ifdef EBCDIC
17182                         && ! non_portable_endpoint
17183 #endif
17184                     ) {
17185                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
17186                         op = POSIXA;
17187                     }
17188                 }
17189                 else if (prevvalue == 'a') {
17190                     if (value == 'z'
17191 #ifdef EBCDIC
17192                         && ! non_portable_endpoint
17193 #endif
17194                     ) {
17195                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
17196                         op = POSIXA;
17197                     }
17198                 }
17199             }
17200         }
17201
17202         /* Here, we have changed <op> away from its initial value iff we found
17203          * an optimization */
17204         if (op != END) {
17205
17206             /* Throw away this ANYOF regnode, and emit the calculated one,
17207              * which should correspond to the beginning, not current, state of
17208              * the parse */
17209             const char * cur_parse = RExC_parse;
17210             RExC_parse = (char *)orig_parse;
17211             if ( SIZE_ONLY) {
17212                 if (! LOC) {
17213
17214                     /* To get locale nodes to not use the full ANYOF size would
17215                      * require moving the code above that writes the portions
17216                      * of it that aren't in other nodes to after this point.
17217                      * e.g.  ANYOF_POSIXL_SET */
17218                     RExC_size = orig_size;
17219                 }
17220             }
17221             else {
17222                 RExC_emit = (regnode *)orig_emit;
17223                 if (PL_regkind[op] == POSIXD) {
17224                     if (op == POSIXL) {
17225                         RExC_contains_locale = 1;
17226                     }
17227                     if (invert) {
17228                         op += NPOSIXD - POSIXD;
17229                     }
17230                 }
17231             }
17232
17233             ret = reg_node(pRExC_state, op);
17234
17235             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17236                 if (! SIZE_ONLY) {
17237                     FLAGS(ret) = arg;
17238                 }
17239                 *flagp |= HASWIDTH|SIMPLE;
17240             }
17241             else if (PL_regkind[op] == EXACT) {
17242                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17243                                            TRUE /* downgradable to EXACT */
17244                                            );
17245             }
17246
17247             RExC_parse = (char *) cur_parse;
17248
17249             SvREFCNT_dec(posixes);
17250             SvREFCNT_dec(nposixes);
17251             SvREFCNT_dec(simple_posixes);
17252             SvREFCNT_dec(cp_list);
17253             SvREFCNT_dec(cp_foldable_list);
17254             return ret;
17255         }
17256     }
17257
17258     if (SIZE_ONLY)
17259         return ret;
17260     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17261
17262     /* If folding, we calculate all characters that could fold to or from the
17263      * ones already on the list */
17264     if (cp_foldable_list) {
17265         if (FOLD) {
17266             UV start, end;      /* End points of code point ranges */
17267
17268             SV* fold_intersection = NULL;
17269             SV** use_list;
17270
17271             /* Our calculated list will be for Unicode rules.  For locale
17272              * matching, we have to keep a separate list that is consulted at
17273              * runtime only when the locale indicates Unicode rules.  For
17274              * non-locale, we just use the general list */
17275             if (LOC) {
17276                 use_list = &only_utf8_locale_list;
17277             }
17278             else {
17279                 use_list = &cp_list;
17280             }
17281
17282             /* Only the characters in this class that participate in folds need
17283              * be checked.  Get the intersection of this class and all the
17284              * possible characters that are foldable.  This can quickly narrow
17285              * down a large class */
17286             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17287                                   &fold_intersection);
17288
17289             /* The folds for all the Latin1 characters are hard-coded into this
17290              * program, but we have to go out to disk to get the others. */
17291             if (invlist_highest(cp_foldable_list) >= 256) {
17292
17293                 /* This is a hash that for a particular fold gives all
17294                  * characters that are involved in it */
17295                 if (! PL_utf8_foldclosures) {
17296                     _load_PL_utf8_foldclosures();
17297                 }
17298             }
17299
17300             /* Now look at the foldable characters in this class individually */
17301             invlist_iterinit(fold_intersection);
17302             while (invlist_iternext(fold_intersection, &start, &end)) {
17303                 UV j;
17304
17305                 /* Look at every character in the range */
17306                 for (j = start; j <= end; j++) {
17307                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17308                     STRLEN foldlen;
17309                     SV** listp;
17310
17311                     if (j < 256) {
17312
17313                         if (IS_IN_SOME_FOLD_L1(j)) {
17314
17315                             /* ASCII is always matched; non-ASCII is matched
17316                              * only under Unicode rules (which could happen
17317                              * under /l if the locale is a UTF-8 one */
17318                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17319                                 *use_list = add_cp_to_invlist(*use_list,
17320                                                             PL_fold_latin1[j]);
17321                             }
17322                             else {
17323                                 has_upper_latin1_only_utf8_matches
17324                                     = add_cp_to_invlist(
17325                                             has_upper_latin1_only_utf8_matches,
17326                                             PL_fold_latin1[j]);
17327                             }
17328                         }
17329
17330                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17331                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17332                         {
17333                             add_above_Latin1_folds(pRExC_state,
17334                                                    (U8) j,
17335                                                    use_list);
17336                         }
17337                         continue;
17338                     }
17339
17340                     /* Here is an above Latin1 character.  We don't have the
17341                      * rules hard-coded for it.  First, get its fold.  This is
17342                      * the simple fold, as the multi-character folds have been
17343                      * handled earlier and separated out */
17344                     _to_uni_fold_flags(j, foldbuf, &foldlen,
17345                                                         (ASCII_FOLD_RESTRICTED)
17346                                                         ? FOLD_FLAGS_NOMIX_ASCII
17347                                                         : 0);
17348
17349                     /* Single character fold of above Latin1.  Add everything in
17350                     * its fold closure to the list that this node should match.
17351                     * The fold closures data structure is a hash with the keys
17352                     * being the UTF-8 of every character that is folded to, like
17353                     * 'k', and the values each an array of all code points that
17354                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
17355                     * Multi-character folds are not included */
17356                     if ((listp = hv_fetch(PL_utf8_foldclosures,
17357                                         (char *) foldbuf, foldlen, FALSE)))
17358                     {
17359                         AV* list = (AV*) *listp;
17360                         IV k;
17361                         for (k = 0; k <= av_tindex_nomg(list); k++) {
17362                             SV** c_p = av_fetch(list, k, FALSE);
17363                             UV c;
17364                             assert(c_p);
17365
17366                             c = SvUV(*c_p);
17367
17368                             /* /aa doesn't allow folds between ASCII and non- */
17369                             if ((ASCII_FOLD_RESTRICTED
17370                                 && (isASCII(c) != isASCII(j))))
17371                             {
17372                                 continue;
17373                             }
17374
17375                             /* Folds under /l which cross the 255/256 boundary
17376                              * are added to a separate list.  (These are valid
17377                              * only when the locale is UTF-8.) */
17378                             if (c < 256 && LOC) {
17379                                 *use_list = add_cp_to_invlist(*use_list, c);
17380                                 continue;
17381                             }
17382
17383                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17384                             {
17385                                 cp_list = add_cp_to_invlist(cp_list, c);
17386                             }
17387                             else {
17388                                 /* Similarly folds involving non-ascii Latin1
17389                                 * characters under /d are added to their list */
17390                                 has_upper_latin1_only_utf8_matches
17391                                         = add_cp_to_invlist(
17392                                            has_upper_latin1_only_utf8_matches,
17393                                            c);
17394                             }
17395                         }
17396                     }
17397                 }
17398             }
17399             SvREFCNT_dec_NN(fold_intersection);
17400         }
17401
17402         /* Now that we have finished adding all the folds, there is no reason
17403          * to keep the foldable list separate */
17404         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17405         SvREFCNT_dec_NN(cp_foldable_list);
17406     }
17407
17408     /* And combine the result (if any) with any inversion lists from posix
17409      * classes.  The lists are kept separate up to now because we don't want to
17410      * fold the classes (folding of those is automatically handled by the swash
17411      * fetching code) */
17412     if (simple_posixes) {   /* These are the classes known to be unaffected by
17413                                /a, /aa, and /d */
17414         if (cp_list) {
17415             _invlist_union(cp_list, simple_posixes, &cp_list);
17416             SvREFCNT_dec_NN(simple_posixes);
17417         }
17418         else {
17419             cp_list = simple_posixes;
17420         }
17421     }
17422     if (posixes || nposixes) {
17423
17424         /* We have to adjust /a and /aa */
17425         if (AT_LEAST_ASCII_RESTRICTED) {
17426
17427             /* Under /a and /aa, nothing above ASCII matches these */
17428             if (posixes) {
17429                 _invlist_intersection(posixes,
17430                                     PL_XPosix_ptrs[_CC_ASCII],
17431                                     &posixes);
17432             }
17433
17434             /* Under /a and /aa, everything above ASCII matches these
17435              * complements */
17436             if (nposixes) {
17437                 _invlist_union_complement_2nd(nposixes,
17438                                               PL_XPosix_ptrs[_CC_ASCII],
17439                                               &nposixes);
17440             }
17441         }
17442
17443         if (! DEPENDS_SEMANTICS) {
17444
17445             /* For everything but /d, we can just add the current 'posixes' and
17446              * 'nposixes' to the main list */
17447             if (posixes) {
17448                 if (cp_list) {
17449                     _invlist_union(cp_list, posixes, &cp_list);
17450                     SvREFCNT_dec_NN(posixes);
17451                 }
17452                 else {
17453                     cp_list = posixes;
17454                 }
17455             }
17456             if (nposixes) {
17457                 if (cp_list) {
17458                     _invlist_union(cp_list, nposixes, &cp_list);
17459                     SvREFCNT_dec_NN(nposixes);
17460                 }
17461                 else {
17462                     cp_list = nposixes;
17463                 }
17464             }
17465         }
17466         else {
17467             /* Under /d, things like \w match upper Latin1 characters only if
17468              * the target string is in UTF-8.  But things like \W match all the
17469              * upper Latin1 characters if the target string is not in UTF-8.
17470              *
17471              * Handle the case where there something like \W separately */
17472             if (nposixes) {
17473                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
17474
17475                 /* A complemented posix class matches all upper Latin1
17476                  * characters if not in UTF-8.  And it matches just certain
17477                  * ones when in UTF-8.  That means those certain ones are
17478                  * matched regardless, so can just be added to the
17479                  * unconditional list */
17480                 if (cp_list) {
17481                     _invlist_union(cp_list, nposixes, &cp_list);
17482                     SvREFCNT_dec_NN(nposixes);
17483                     nposixes = NULL;
17484                 }
17485                 else {
17486                     cp_list = nposixes;
17487                 }
17488
17489                 /* Likewise for 'posixes' */
17490                 _invlist_union(posixes, cp_list, &cp_list);
17491
17492                 /* Likewise for anything else in the range that matched only
17493                  * under UTF-8 */
17494                 if (has_upper_latin1_only_utf8_matches) {
17495                     _invlist_union(cp_list,
17496                                    has_upper_latin1_only_utf8_matches,
17497                                    &cp_list);
17498                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17499                     has_upper_latin1_only_utf8_matches = NULL;
17500                 }
17501
17502                 /* If we don't match all the upper Latin1 characters regardless
17503                  * of UTF-8ness, we have to set a flag to match the rest when
17504                  * not in UTF-8 */
17505                 _invlist_subtract(only_non_utf8_list, cp_list,
17506                                   &only_non_utf8_list);
17507                 if (_invlist_len(only_non_utf8_list) != 0) {
17508                     ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17509                 }
17510             }
17511             else {
17512                 /* Here there were no complemented posix classes.  That means
17513                  * the upper Latin1 characters in 'posixes' match only when the
17514                  * target string is in UTF-8.  So we have to add them to the
17515                  * list of those types of code points, while adding the
17516                  * remainder to the unconditional list.
17517                  *
17518                  * First calculate what they are */
17519                 SV* nonascii_but_latin1_properties = NULL;
17520                 _invlist_intersection(posixes, PL_UpperLatin1,
17521                                       &nonascii_but_latin1_properties);
17522
17523                 /* And add them to the final list of such characters. */
17524                 _invlist_union(has_upper_latin1_only_utf8_matches,
17525                                nonascii_but_latin1_properties,
17526                                &has_upper_latin1_only_utf8_matches);
17527
17528                 /* Remove them from what now becomes the unconditional list */
17529                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
17530                                   &posixes);
17531
17532                 /* And add those unconditional ones to the final list */
17533                 if (cp_list) {
17534                     _invlist_union(cp_list, posixes, &cp_list);
17535                     SvREFCNT_dec_NN(posixes);
17536                     posixes = NULL;
17537                 }
17538                 else {
17539                     cp_list = posixes;
17540                 }
17541
17542                 SvREFCNT_dec(nonascii_but_latin1_properties);
17543
17544                 /* Get rid of any characters that we now know are matched
17545                  * unconditionally from the conditional list, which may make
17546                  * that list empty */
17547                 _invlist_subtract(has_upper_latin1_only_utf8_matches,
17548                                   cp_list,
17549                                   &has_upper_latin1_only_utf8_matches);
17550                 if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
17551                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17552                     has_upper_latin1_only_utf8_matches = NULL;
17553                 }
17554             }
17555         }
17556     }
17557
17558     /* And combine the result (if any) with any inversion list from properties.
17559      * The lists are kept separate up to now so that we can distinguish the two
17560      * in regards to matching above-Unicode.  A run-time warning is generated
17561      * if a Unicode property is matched against a non-Unicode code point. But,
17562      * we allow user-defined properties to match anything, without any warning,
17563      * and we also suppress the warning if there is a portion of the character
17564      * class that isn't a Unicode property, and which matches above Unicode, \W
17565      * or [\x{110000}] for example.
17566      * (Note that in this case, unlike the Posix one above, there is no
17567      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
17568      * forces Unicode semantics */
17569     if (properties) {
17570         if (cp_list) {
17571
17572             /* If it matters to the final outcome, see if a non-property
17573              * component of the class matches above Unicode.  If so, the
17574              * warning gets suppressed.  This is true even if just a single
17575              * such code point is specified, as, though not strictly correct if
17576              * another such code point is matched against, the fact that they
17577              * are using above-Unicode code points indicates they should know
17578              * the issues involved */
17579             if (warn_super) {
17580                 warn_super = ! (invert
17581                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
17582             }
17583
17584             _invlist_union(properties, cp_list, &cp_list);
17585             SvREFCNT_dec_NN(properties);
17586         }
17587         else {
17588             cp_list = properties;
17589         }
17590
17591         if (warn_super) {
17592             ANYOF_FLAGS(ret)
17593              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17594
17595             /* Because an ANYOF node is the only one that warns, this node
17596              * can't be optimized into something else */
17597             optimizable = FALSE;
17598         }
17599     }
17600
17601     /* Here, we have calculated what code points should be in the character
17602      * class.
17603      *
17604      * Now we can see about various optimizations.  Fold calculation (which we
17605      * did above) needs to take place before inversion.  Otherwise /[^k]/i
17606      * would invert to include K, which under /i would match k, which it
17607      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
17608      * folded until runtime */
17609
17610     /* If we didn't do folding, it's because some information isn't available
17611      * until runtime; set the run-time fold flag for these.  (We don't have to
17612      * worry about properties folding, as that is taken care of by the swash
17613      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
17614      * locales, or the class matches at least one 0-255 range code point */
17615     if (LOC && FOLD) {
17616
17617         /* Some things on the list might be unconditionally included because of
17618          * other components.  Remove them, and clean up the list if it goes to
17619          * 0 elements */
17620         if (only_utf8_locale_list && cp_list) {
17621             _invlist_subtract(only_utf8_locale_list, cp_list,
17622                               &only_utf8_locale_list);
17623
17624             if (_invlist_len(only_utf8_locale_list) == 0) {
17625                 SvREFCNT_dec_NN(only_utf8_locale_list);
17626                 only_utf8_locale_list = NULL;
17627             }
17628         }
17629         if (only_utf8_locale_list) {
17630             ANYOF_FLAGS(ret)
17631                  |=  ANYOFL_FOLD
17632                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
17633         }
17634         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
17635             UV start, end;
17636             invlist_iterinit(cp_list);
17637             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
17638                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
17639             }
17640             invlist_iterfinish(cp_list);
17641         }
17642     }
17643     else if (   DEPENDS_SEMANTICS
17644              && (    has_upper_latin1_only_utf8_matches
17645                  || (ANYOF_FLAGS(ret) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
17646     {
17647         OP(ret) = ANYOFD;
17648         optimizable = FALSE;
17649     }
17650
17651
17652     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
17653      * at compile time.  Besides not inverting folded locale now, we can't
17654      * invert if there are things such as \w, which aren't known until runtime
17655      * */
17656     if (cp_list
17657         && invert
17658         && OP(ret) != ANYOFD
17659         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
17660         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17661     {
17662         _invlist_invert(cp_list);
17663
17664         /* Any swash can't be used as-is, because we've inverted things */
17665         if (swash) {
17666             SvREFCNT_dec_NN(swash);
17667             swash = NULL;
17668         }
17669
17670         /* Clear the invert flag since have just done it here */
17671         invert = FALSE;
17672     }
17673
17674     if (ret_invlist) {
17675         assert(cp_list);
17676
17677         *ret_invlist = cp_list;
17678         SvREFCNT_dec(swash);
17679
17680         /* Discard the generated node */
17681         if (SIZE_ONLY) {
17682             RExC_size = orig_size;
17683         }
17684         else {
17685             RExC_emit = orig_emit;
17686         }
17687         return orig_emit;
17688     }
17689
17690     /* Some character classes are equivalent to other nodes.  Such nodes take
17691      * up less room and generally fewer operations to execute than ANYOF nodes.
17692      * Above, we checked for and optimized into some such equivalents for
17693      * certain common classes that are easy to test.  Getting to this point in
17694      * the code means that the class didn't get optimized there.  Since this
17695      * code is only executed in Pass 2, it is too late to save space--it has
17696      * been allocated in Pass 1, and currently isn't given back.  But turning
17697      * things into an EXACTish node can allow the optimizer to join it to any
17698      * adjacent such nodes.  And if the class is equivalent to things like /./,
17699      * expensive run-time swashes can be avoided.  Now that we have more
17700      * complete information, we can find things necessarily missed by the
17701      * earlier code.  Another possible "optimization" that isn't done is that
17702      * something like [Ee] could be changed into an EXACTFU.  khw tried this
17703      * and found that the ANYOF is faster, including for code points not in the
17704      * bitmap.  This still might make sense to do, provided it got joined with
17705      * an adjacent node(s) to create a longer EXACTFU one.  This could be
17706      * accomplished by creating a pseudo ANYOF_EXACTFU node type that the join
17707      * routine would know is joinable.  If that didn't happen, the node type
17708      * could then be made a straight ANYOF */
17709
17710     if (optimizable && cp_list && ! invert) {
17711         UV start, end;
17712         U8 op = END;  /* The optimzation node-type */
17713         int posix_class = -1;   /* Illegal value */
17714         const char * cur_parse= RExC_parse;
17715
17716         invlist_iterinit(cp_list);
17717         if (! invlist_iternext(cp_list, &start, &end)) {
17718
17719             /* Here, the list is empty.  This happens, for example, when a
17720              * Unicode property that doesn't match anything is the only element
17721              * in the character class (perluniprops.pod notes such properties).
17722              * */
17723             op = OPFAIL;
17724             *flagp |= HASWIDTH|SIMPLE;
17725         }
17726         else if (start == end) {    /* The range is a single code point */
17727             if (! invlist_iternext(cp_list, &start, &end)
17728
17729                     /* Don't do this optimization if it would require changing
17730                      * the pattern to UTF-8 */
17731                 && (start < 256 || UTF))
17732             {
17733                 /* Here, the list contains a single code point.  Can optimize
17734                  * into an EXACTish node */
17735
17736                 value = start;
17737
17738                 if (! FOLD) {
17739                     op = (LOC)
17740                          ? EXACTL
17741                          : EXACT;
17742                 }
17743                 else if (LOC) {
17744
17745                     /* A locale node under folding with one code point can be
17746                      * an EXACTFL, as its fold won't be calculated until
17747                      * runtime */
17748                     op = EXACTFL;
17749                 }
17750                 else {
17751
17752                     /* Here, we are generally folding, but there is only one
17753                      * code point to match.  If we have to, we use an EXACT
17754                      * node, but it would be better for joining with adjacent
17755                      * nodes in the optimization pass if we used the same
17756                      * EXACTFish node that any such are likely to be.  We can
17757                      * do this iff the code point doesn't participate in any
17758                      * folds.  For example, an EXACTF of a colon is the same as
17759                      * an EXACT one, since nothing folds to or from a colon. */
17760                     if (value < 256) {
17761                         if (IS_IN_SOME_FOLD_L1(value)) {
17762                             op = EXACT;
17763                         }
17764                     }
17765                     else {
17766                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
17767                             op = EXACT;
17768                         }
17769                     }
17770
17771                     /* If we haven't found the node type, above, it means we
17772                      * can use the prevailing one */
17773                     if (op == END) {
17774                         op = compute_EXACTish(pRExC_state);
17775                     }
17776                 }
17777             }
17778         }   /* End of first range contains just a single code point */
17779         else if (start == 0) {
17780             if (end == UV_MAX) {
17781                 op = SANY;
17782                 *flagp |= HASWIDTH|SIMPLE;
17783                 MARK_NAUGHTY(1);
17784             }
17785             else if (end == '\n' - 1
17786                     && invlist_iternext(cp_list, &start, &end)
17787                     && start == '\n' + 1 && end == UV_MAX)
17788             {
17789                 op = REG_ANY;
17790                 *flagp |= HASWIDTH|SIMPLE;
17791                 MARK_NAUGHTY(1);
17792             }
17793         }
17794         invlist_iterfinish(cp_list);
17795
17796         if (op == END) {
17797             const UV cp_list_len = _invlist_len(cp_list);
17798             const UV* cp_list_array = invlist_array(cp_list);
17799
17800             /* Here, didn't find an optimization.  See if this matches any of
17801              * the POSIX classes.  These run slightly faster for above-Unicode
17802              * code points, so don't bother with POSIXA ones nor the 2 that
17803              * have no above-Unicode matches.  We can avoid these checks unless
17804              * the ANYOF matches at least as high as the lowest POSIX one
17805              * (which was manually found to be \v.  The actual code point may
17806              * increase in later Unicode releases, if a higher code point is
17807              * assigned to be \v, but this code will never break.  It would
17808              * just mean we could execute the checks for posix optimizations
17809              * unnecessarily) */
17810
17811             if (cp_list_array[cp_list_len-1] > 0x2029) {
17812                 for (posix_class = 0;
17813                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
17814                      posix_class++)
17815                 {
17816                     int try_inverted;
17817                     if (posix_class == _CC_ASCII || posix_class == _CC_CNTRL) {
17818                         continue;
17819                     }
17820                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
17821
17822                         /* Check if matches normal or inverted */
17823                         if (_invlistEQ(cp_list,
17824                                        PL_XPosix_ptrs[posix_class],
17825                                        try_inverted))
17826                         {
17827                             op = (try_inverted)
17828                                  ? NPOSIXU
17829                                  : POSIXU;
17830                             *flagp |= HASWIDTH|SIMPLE;
17831                             goto found_posix;
17832                         }
17833                     }
17834                 }
17835               found_posix: ;
17836             }
17837         }
17838
17839         if (op != END) {
17840             RExC_parse = (char *)orig_parse;
17841             RExC_emit = (regnode *)orig_emit;
17842
17843             if (regarglen[op]) {
17844                 ret = reganode(pRExC_state, op, 0);
17845             } else {
17846                 ret = reg_node(pRExC_state, op);
17847             }
17848
17849             RExC_parse = (char *)cur_parse;
17850
17851             if (PL_regkind[op] == EXACT) {
17852                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17853                                            TRUE /* downgradable to EXACT */
17854                                           );
17855             }
17856             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17857                 FLAGS(ret) = posix_class;
17858             }
17859
17860             SvREFCNT_dec_NN(cp_list);
17861             return ret;
17862         }
17863     }
17864
17865     /* Here, <cp_list> contains all the code points we can determine at
17866      * compile time that match under all conditions.  Go through it, and
17867      * for things that belong in the bitmap, put them there, and delete from
17868      * <cp_list>.  While we are at it, see if everything above 255 is in the
17869      * list, and if so, set a flag to speed up execution */
17870
17871     populate_ANYOF_from_invlist(ret, &cp_list);
17872
17873     if (invert) {
17874         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
17875     }
17876
17877     /* Here, the bitmap has been populated with all the Latin1 code points that
17878      * always match.  Can now add to the overall list those that match only
17879      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
17880      * */
17881     if (has_upper_latin1_only_utf8_matches) {
17882         if (cp_list) {
17883             _invlist_union(cp_list,
17884                            has_upper_latin1_only_utf8_matches,
17885                            &cp_list);
17886             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17887         }
17888         else {
17889             cp_list = has_upper_latin1_only_utf8_matches;
17890         }
17891         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17892     }
17893
17894     /* If there is a swash and more than one element, we can't use the swash in
17895      * the optimization below. */
17896     if (swash && element_count > 1) {
17897         SvREFCNT_dec_NN(swash);
17898         swash = NULL;
17899     }
17900
17901     /* Note that the optimization of using 'swash' if it is the only thing in
17902      * the class doesn't have us change swash at all, so it can include things
17903      * that are also in the bitmap; otherwise we have purposely deleted that
17904      * duplicate information */
17905     set_ANYOF_arg(pRExC_state, ret, cp_list,
17906                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17907                    ? listsv : NULL,
17908                   only_utf8_locale_list,
17909                   swash, has_user_defined_property);
17910
17911     *flagp |= HASWIDTH|SIMPLE;
17912
17913     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
17914         RExC_contains_locale = 1;
17915     }
17916
17917     return ret;
17918 }
17919
17920 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
17921
17922 STATIC void
17923 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
17924                 regnode* const node,
17925                 SV* const cp_list,
17926                 SV* const runtime_defns,
17927                 SV* const only_utf8_locale_list,
17928                 SV* const swash,
17929                 const bool has_user_defined_property)
17930 {
17931     /* Sets the arg field of an ANYOF-type node 'node', using information about
17932      * the node passed-in.  If there is nothing outside the node's bitmap, the
17933      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
17934      * the count returned by add_data(), having allocated and stored an array,
17935      * av, that that count references, as follows:
17936      *  av[0] stores the character class description in its textual form.
17937      *        This is used later (regexec.c:Perl_regclass_swash()) to
17938      *        initialize the appropriate swash, and is also useful for dumping
17939      *        the regnode.  This is set to &PL_sv_undef if the textual
17940      *        description is not needed at run-time (as happens if the other
17941      *        elements completely define the class)
17942      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
17943      *        computed from av[0].  But if no further computation need be done,
17944      *        the swash is stored here now (and av[0] is &PL_sv_undef).
17945      *  av[2] stores the inversion list of code points that match only if the
17946      *        current locale is UTF-8
17947      *  av[3] stores the cp_list inversion list for use in addition or instead
17948      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
17949      *        (Otherwise everything needed is already in av[0] and av[1])
17950      *  av[4] is set if any component of the class is from a user-defined
17951      *        property; used only if av[3] exists */
17952
17953     UV n;
17954
17955     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
17956
17957     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
17958         assert(! (ANYOF_FLAGS(node)
17959                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
17960         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
17961     }
17962     else {
17963         AV * const av = newAV();
17964         SV *rv;
17965
17966         av_store(av, 0, (runtime_defns)
17967                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
17968         if (swash) {
17969             assert(cp_list);
17970             av_store(av, 1, swash);
17971             SvREFCNT_dec_NN(cp_list);
17972         }
17973         else {
17974             av_store(av, 1, &PL_sv_undef);
17975             if (cp_list) {
17976                 av_store(av, 3, cp_list);
17977                 av_store(av, 4, newSVuv(has_user_defined_property));
17978             }
17979         }
17980
17981         if (only_utf8_locale_list) {
17982             av_store(av, 2, only_utf8_locale_list);
17983         }
17984         else {
17985             av_store(av, 2, &PL_sv_undef);
17986         }
17987
17988         rv = newRV_noinc(MUTABLE_SV(av));
17989         n = add_data(pRExC_state, STR_WITH_LEN("s"));
17990         RExC_rxi->data->data[n] = (void*)rv;
17991         ARG_SET(node, n);
17992     }
17993 }
17994
17995 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
17996 SV *
17997 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
17998                                         const regnode* node,
17999                                         bool doinit,
18000                                         SV** listsvp,
18001                                         SV** only_utf8_locale_ptr,
18002                                         SV** output_invlist)
18003
18004 {
18005     /* For internal core use only.
18006      * Returns the swash for the input 'node' in the regex 'prog'.
18007      * If <doinit> is 'true', will attempt to create the swash if not already
18008      *    done.
18009      * If <listsvp> is non-null, will return the printable contents of the
18010      *    swash.  This can be used to get debugging information even before the
18011      *    swash exists, by calling this function with 'doinit' set to false, in
18012      *    which case the components that will be used to eventually create the
18013      *    swash are returned  (in a printable form).
18014      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
18015      *    store an inversion list of code points that should match only if the
18016      *    execution-time locale is a UTF-8 one.
18017      * If <output_invlist> is not NULL, it is where this routine is to store an
18018      *    inversion list of the code points that would be instead returned in
18019      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
18020      *    when this parameter is used, is just the non-code point data that
18021      *    will go into creating the swash.  This currently should be just
18022      *    user-defined properties whose definitions were not known at compile
18023      *    time.  Using this parameter allows for easier manipulation of the
18024      *    swash's data by the caller.  It is illegal to call this function with
18025      *    this parameter set, but not <listsvp>
18026      *
18027      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
18028      * that, in spite of this function's name, the swash it returns may include
18029      * the bitmap data as well */
18030
18031     SV *sw  = NULL;
18032     SV *si  = NULL;         /* Input swash initialization string */
18033     SV* invlist = NULL;
18034
18035     RXi_GET_DECL(prog,progi);
18036     const struct reg_data * const data = prog ? progi->data : NULL;
18037
18038     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
18039     assert(! output_invlist || listsvp);
18040
18041     if (data && data->count) {
18042         const U32 n = ARG(node);
18043
18044         if (data->what[n] == 's') {
18045             SV * const rv = MUTABLE_SV(data->data[n]);
18046             AV * const av = MUTABLE_AV(SvRV(rv));
18047             SV **const ary = AvARRAY(av);
18048             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
18049
18050             si = *ary;  /* ary[0] = the string to initialize the swash with */
18051
18052             if (av_tindex_nomg(av) >= 2) {
18053                 if (only_utf8_locale_ptr
18054                     && ary[2]
18055                     && ary[2] != &PL_sv_undef)
18056                 {
18057                     *only_utf8_locale_ptr = ary[2];
18058                 }
18059                 else {
18060                     assert(only_utf8_locale_ptr);
18061                     *only_utf8_locale_ptr = NULL;
18062                 }
18063
18064                 /* Elements 3 and 4 are either both present or both absent. [3]
18065                  * is any inversion list generated at compile time; [4]
18066                  * indicates if that inversion list has any user-defined
18067                  * properties in it. */
18068                 if (av_tindex_nomg(av) >= 3) {
18069                     invlist = ary[3];
18070                     if (SvUV(ary[4])) {
18071                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
18072                     }
18073                 }
18074                 else {
18075                     invlist = NULL;
18076                 }
18077             }
18078
18079             /* Element [1] is reserved for the set-up swash.  If already there,
18080              * return it; if not, create it and store it there */
18081             if (ary[1] && SvROK(ary[1])) {
18082                 sw = ary[1];
18083             }
18084             else if (doinit && ((si && si != &PL_sv_undef)
18085                                  || (invlist && invlist != &PL_sv_undef))) {
18086                 assert(si);
18087                 sw = _core_swash_init("utf8", /* the utf8 package */
18088                                       "", /* nameless */
18089                                       si,
18090                                       1, /* binary */
18091                                       0, /* not from tr/// */
18092                                       invlist,
18093                                       &swash_init_flags);
18094                 (void)av_store(av, 1, sw);
18095             }
18096         }
18097     }
18098
18099     /* If requested, return a printable version of what this swash matches */
18100     if (listsvp) {
18101         SV* matches_string = NULL;
18102
18103         /* The swash should be used, if possible, to get the data, as it
18104          * contains the resolved data.  But this function can be called at
18105          * compile-time, before everything gets resolved, in which case we
18106          * return the currently best available information, which is the string
18107          * that will eventually be used to do that resolving, 'si' */
18108         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
18109             && (si && si != &PL_sv_undef))
18110         {
18111             /* Here, we only have 'si' (and possibly some passed-in data in
18112              * 'invlist', which is handled below)  If the caller only wants
18113              * 'si', use that.  */
18114             if (! output_invlist) {
18115                 matches_string = newSVsv(si);
18116             }
18117             else {
18118                 /* But if the caller wants an inversion list of the node, we
18119                  * need to parse 'si' and place as much as possible in the
18120                  * desired output inversion list, making 'matches_string' only
18121                  * contain the currently unresolvable things */
18122                 const char *si_string = SvPVX(si);
18123                 STRLEN remaining = SvCUR(si);
18124                 UV prev_cp = 0;
18125                 U8 count = 0;
18126
18127                 /* Ignore everything before the first new-line */
18128                 while (*si_string != '\n' && remaining > 0) {
18129                     si_string++;
18130                     remaining--;
18131                 }
18132                 assert(remaining > 0);
18133
18134                 si_string++;
18135                 remaining--;
18136
18137                 while (remaining > 0) {
18138
18139                     /* The data consists of just strings defining user-defined
18140                      * property names, but in prior incarnations, and perhaps
18141                      * somehow from pluggable regex engines, it could still
18142                      * hold hex code point definitions.  Each component of a
18143                      * range would be separated by a tab, and each range by a
18144                      * new-line.  If these are found, instead add them to the
18145                      * inversion list */
18146                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
18147                                      |PERL_SCAN_SILENT_NON_PORTABLE;
18148                     STRLEN len = remaining;
18149                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
18150
18151                     /* If the hex decode routine found something, it should go
18152                      * up to the next \n */
18153                     if (   *(si_string + len) == '\n') {
18154                         if (count) {    /* 2nd code point on line */
18155                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
18156                         }
18157                         else {
18158                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
18159                         }
18160                         count = 0;
18161                         goto prepare_for_next_iteration;
18162                     }
18163
18164                     /* If the hex decode was instead for the lower range limit,
18165                      * save it, and go parse the upper range limit */
18166                     if (*(si_string + len) == '\t') {
18167                         assert(count == 0);
18168
18169                         prev_cp = cp;
18170                         count = 1;
18171                       prepare_for_next_iteration:
18172                         si_string += len + 1;
18173                         remaining -= len + 1;
18174                         continue;
18175                     }
18176
18177                     /* Here, didn't find a legal hex number.  Just add it from
18178                      * here to the next \n */
18179
18180                     remaining -= len;
18181                     while (*(si_string + len) != '\n' && remaining > 0) {
18182                         remaining--;
18183                         len++;
18184                     }
18185                     if (*(si_string + len) == '\n') {
18186                         len++;
18187                         remaining--;
18188                     }
18189                     if (matches_string) {
18190                         sv_catpvn(matches_string, si_string, len - 1);
18191                     }
18192                     else {
18193                         matches_string = newSVpvn(si_string, len - 1);
18194                     }
18195                     si_string += len;
18196                     sv_catpvs(matches_string, " ");
18197                 } /* end of loop through the text */
18198
18199                 assert(matches_string);
18200                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
18201                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
18202                 }
18203             } /* end of has an 'si' but no swash */
18204         }
18205
18206         /* If we have a swash in place, its equivalent inversion list was above
18207          * placed into 'invlist'.  If not, this variable may contain a stored
18208          * inversion list which is information beyond what is in 'si' */
18209         if (invlist) {
18210
18211             /* Again, if the caller doesn't want the output inversion list, put
18212              * everything in 'matches-string' */
18213             if (! output_invlist) {
18214                 if ( ! matches_string) {
18215                     matches_string = newSVpvs("\n");
18216                 }
18217                 sv_catsv(matches_string, invlist_contents(invlist,
18218                                                   TRUE /* traditional style */
18219                                                   ));
18220             }
18221             else if (! *output_invlist) {
18222                 *output_invlist = invlist_clone(invlist);
18223             }
18224             else {
18225                 _invlist_union(*output_invlist, invlist, output_invlist);
18226             }
18227         }
18228
18229         *listsvp = matches_string;
18230     }
18231
18232     return sw;
18233 }
18234 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18235
18236 /* reg_skipcomment()
18237
18238    Absorbs an /x style # comment from the input stream,
18239    returning a pointer to the first character beyond the comment, or if the
18240    comment terminates the pattern without anything following it, this returns
18241    one past the final character of the pattern (in other words, RExC_end) and
18242    sets the REG_RUN_ON_COMMENT_SEEN flag.
18243
18244    Note it's the callers responsibility to ensure that we are
18245    actually in /x mode
18246
18247 */
18248
18249 PERL_STATIC_INLINE char*
18250 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18251 {
18252     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18253
18254     assert(*p == '#');
18255
18256     while (p < RExC_end) {
18257         if (*(++p) == '\n') {
18258             return p+1;
18259         }
18260     }
18261
18262     /* we ran off the end of the pattern without ending the comment, so we have
18263      * to add an \n when wrapping */
18264     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18265     return p;
18266 }
18267
18268 STATIC void
18269 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18270                                 char ** p,
18271                                 const bool force_to_xmod
18272                          )
18273 {
18274     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18275      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18276      * is /x whitespace, advance '*p' so that on exit it points to the first
18277      * byte past all such white space and comments */
18278
18279     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18280
18281     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18282
18283     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18284
18285     for (;;) {
18286         if (RExC_end - (*p) >= 3
18287             && *(*p)     == '('
18288             && *(*p + 1) == '?'
18289             && *(*p + 2) == '#')
18290         {
18291             while (*(*p) != ')') {
18292                 if ((*p) == RExC_end)
18293                     FAIL("Sequence (?#... not terminated");
18294                 (*p)++;
18295             }
18296             (*p)++;
18297             continue;
18298         }
18299
18300         if (use_xmod) {
18301             const char * save_p = *p;
18302             while ((*p) < RExC_end) {
18303                 STRLEN len;
18304                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18305                     (*p) += len;
18306                 }
18307                 else if (*(*p) == '#') {
18308                     (*p) = reg_skipcomment(pRExC_state, (*p));
18309                 }
18310                 else {
18311                     break;
18312                 }
18313             }
18314             if (*p != save_p) {
18315                 continue;
18316             }
18317         }
18318
18319         break;
18320     }
18321
18322     return;
18323 }
18324
18325 /* nextchar()
18326
18327    Advances the parse position by one byte, unless that byte is the beginning
18328    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
18329    those two cases, the parse position is advanced beyond all such comments and
18330    white space.
18331
18332    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
18333 */
18334
18335 STATIC void
18336 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
18337 {
18338     PERL_ARGS_ASSERT_NEXTCHAR;
18339
18340     if (RExC_parse < RExC_end) {
18341         assert(   ! UTF
18342                || UTF8_IS_INVARIANT(*RExC_parse)
18343                || UTF8_IS_START(*RExC_parse));
18344
18345         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
18346
18347         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
18348                                 FALSE /* Don't force /x */ );
18349     }
18350 }
18351
18352 STATIC regnode *
18353 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
18354 {
18355     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
18356      * space.  In pass1, it aligns and increments RExC_size; in pass2,
18357      * RExC_emit */
18358
18359     regnode * const ret = RExC_emit;
18360     GET_RE_DEBUG_FLAGS_DECL;
18361
18362     PERL_ARGS_ASSERT_REGNODE_GUTS;
18363
18364     assert(extra_size >= regarglen[op]);
18365
18366     if (SIZE_ONLY) {
18367         SIZE_ALIGN(RExC_size);
18368         RExC_size += 1 + extra_size;
18369         return(ret);
18370     }
18371     if (RExC_emit >= RExC_emit_bound)
18372         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
18373                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
18374
18375     NODE_ALIGN_FILL(ret);
18376 #ifndef RE_TRACK_PATTERN_OFFSETS
18377     PERL_UNUSED_ARG(name);
18378 #else
18379     if (RExC_offsets) {         /* MJD */
18380         MJD_OFFSET_DEBUG(
18381               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
18382               name, __LINE__,
18383               PL_reg_name[op],
18384               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
18385                 ? "Overwriting end of array!\n" : "OK",
18386               (UV)(RExC_emit - RExC_emit_start),
18387               (UV)(RExC_parse - RExC_start),
18388               (UV)RExC_offsets[0]));
18389         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
18390     }
18391 #endif
18392     return(ret);
18393 }
18394
18395 /*
18396 - reg_node - emit a node
18397 */
18398 STATIC regnode *                        /* Location. */
18399 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
18400 {
18401     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
18402
18403     PERL_ARGS_ASSERT_REG_NODE;
18404
18405     assert(regarglen[op] == 0);
18406
18407     if (PASS2) {
18408         regnode *ptr = ret;
18409         FILL_ADVANCE_NODE(ptr, op);
18410         RExC_emit = ptr;
18411     }
18412     return(ret);
18413 }
18414
18415 /*
18416 - reganode - emit a node with an argument
18417 */
18418 STATIC regnode *                        /* Location. */
18419 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
18420 {
18421     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
18422
18423     PERL_ARGS_ASSERT_REGANODE;
18424
18425     assert(regarglen[op] == 1);
18426
18427     if (PASS2) {
18428         regnode *ptr = ret;
18429         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
18430         RExC_emit = ptr;
18431     }
18432     return(ret);
18433 }
18434
18435 STATIC regnode *
18436 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
18437 {
18438     /* emit a node with U32 and I32 arguments */
18439
18440     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
18441
18442     PERL_ARGS_ASSERT_REG2LANODE;
18443
18444     assert(regarglen[op] == 2);
18445
18446     if (PASS2) {
18447         regnode *ptr = ret;
18448         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
18449         RExC_emit = ptr;
18450     }
18451     return(ret);
18452 }
18453
18454 /*
18455 - reginsert - insert an operator in front of already-emitted operand
18456 *
18457 * Means relocating the operand.
18458 */
18459 STATIC void
18460 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
18461 {
18462     regnode *src;
18463     regnode *dst;
18464     regnode *place;
18465     const int offset = regarglen[(U8)op];
18466     const int size = NODE_STEP_REGNODE + offset;
18467     GET_RE_DEBUG_FLAGS_DECL;
18468
18469     PERL_ARGS_ASSERT_REGINSERT;
18470     PERL_UNUSED_CONTEXT;
18471     PERL_UNUSED_ARG(depth);
18472 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
18473     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
18474     if (SIZE_ONLY) {
18475         RExC_size += size;
18476         return;
18477     }
18478     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
18479                                     studying. If this is wrong then we need to adjust RExC_recurse
18480                                     below like we do with RExC_open_parens/RExC_close_parens. */
18481     src = RExC_emit;
18482     RExC_emit += size;
18483     dst = RExC_emit;
18484     if (RExC_open_parens) {
18485         int paren;
18486         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
18487         /* remember that RExC_npar is rex->nparens + 1,
18488          * iow it is 1 more than the number of parens seen in
18489          * the pattern so far. */
18490         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
18491             /* note, RExC_open_parens[0] is the start of the
18492              * regex, it can't move. RExC_close_parens[0] is the end
18493              * of the regex, it *can* move. */
18494             if ( paren && RExC_open_parens[paren] >= opnd ) {
18495                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
18496                 RExC_open_parens[paren] += size;
18497             } else {
18498                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
18499             }
18500             if ( RExC_close_parens[paren] >= opnd ) {
18501                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
18502                 RExC_close_parens[paren] += size;
18503             } else {
18504                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
18505             }
18506         }
18507     }
18508     if (RExC_end_op)
18509         RExC_end_op += size;
18510
18511     while (src > opnd) {
18512         StructCopy(--src, --dst, regnode);
18513 #ifdef RE_TRACK_PATTERN_OFFSETS
18514         if (RExC_offsets) {     /* MJD 20010112 */
18515             MJD_OFFSET_DEBUG(
18516                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
18517                   "reg_insert",
18518                   __LINE__,
18519                   PL_reg_name[op],
18520                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
18521                     ? "Overwriting end of array!\n" : "OK",
18522                   (UV)(src - RExC_emit_start),
18523                   (UV)(dst - RExC_emit_start),
18524                   (UV)RExC_offsets[0]));
18525             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
18526             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
18527         }
18528 #endif
18529     }
18530
18531
18532     place = opnd;               /* Op node, where operand used to be. */
18533 #ifdef RE_TRACK_PATTERN_OFFSETS
18534     if (RExC_offsets) {         /* MJD */
18535         MJD_OFFSET_DEBUG(
18536               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
18537               "reginsert",
18538               __LINE__,
18539               PL_reg_name[op],
18540               (UV)(place - RExC_emit_start) > RExC_offsets[0]
18541               ? "Overwriting end of array!\n" : "OK",
18542               (UV)(place - RExC_emit_start),
18543               (UV)(RExC_parse - RExC_start),
18544               (UV)RExC_offsets[0]));
18545         Set_Node_Offset(place, RExC_parse);
18546         Set_Node_Length(place, 1);
18547     }
18548 #endif
18549     src = NEXTOPER(place);
18550     FILL_ADVANCE_NODE(place, op);
18551     Zero(src, offset, regnode);
18552 }
18553
18554 /*
18555 - regtail - set the next-pointer at the end of a node chain of p to val.
18556 - SEE ALSO: regtail_study
18557 */
18558 STATIC void
18559 S_regtail(pTHX_ RExC_state_t * pRExC_state,
18560                 const regnode * const p,
18561                 const regnode * const val,
18562                 const U32 depth)
18563 {
18564     regnode *scan;
18565     GET_RE_DEBUG_FLAGS_DECL;
18566
18567     PERL_ARGS_ASSERT_REGTAIL;
18568 #ifndef DEBUGGING
18569     PERL_UNUSED_ARG(depth);
18570 #endif
18571
18572     if (SIZE_ONLY)
18573         return;
18574
18575     /* Find last node. */
18576     scan = (regnode *) p;
18577     for (;;) {
18578         regnode * const temp = regnext(scan);
18579         DEBUG_PARSE_r({
18580             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
18581             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18582             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
18583                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
18584                     (temp == NULL ? "->" : ""),
18585                     (temp == NULL ? PL_reg_name[OP(val)] : "")
18586             );
18587         });
18588         if (temp == NULL)
18589             break;
18590         scan = temp;
18591     }
18592
18593     if (reg_off_by_arg[OP(scan)]) {
18594         ARG_SET(scan, val - scan);
18595     }
18596     else {
18597         NEXT_OFF(scan) = val - scan;
18598     }
18599 }
18600
18601 #ifdef DEBUGGING
18602 /*
18603 - regtail_study - set the next-pointer at the end of a node chain of p to val.
18604 - Look for optimizable sequences at the same time.
18605 - currently only looks for EXACT chains.
18606
18607 This is experimental code. The idea is to use this routine to perform
18608 in place optimizations on branches and groups as they are constructed,
18609 with the long term intention of removing optimization from study_chunk so
18610 that it is purely analytical.
18611
18612 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
18613 to control which is which.
18614
18615 */
18616 /* TODO: All four parms should be const */
18617
18618 STATIC U8
18619 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
18620                       const regnode *val,U32 depth)
18621 {
18622     regnode *scan;
18623     U8 exact = PSEUDO;
18624 #ifdef EXPERIMENTAL_INPLACESCAN
18625     I32 min = 0;
18626 #endif
18627     GET_RE_DEBUG_FLAGS_DECL;
18628
18629     PERL_ARGS_ASSERT_REGTAIL_STUDY;
18630
18631
18632     if (SIZE_ONLY)
18633         return exact;
18634
18635     /* Find last node. */
18636
18637     scan = p;
18638     for (;;) {
18639         regnode * const temp = regnext(scan);
18640 #ifdef EXPERIMENTAL_INPLACESCAN
18641         if (PL_regkind[OP(scan)] == EXACT) {
18642             bool unfolded_multi_char;   /* Unexamined in this routine */
18643             if (join_exact(pRExC_state, scan, &min,
18644                            &unfolded_multi_char, 1, val, depth+1))
18645                 return EXACT;
18646         }
18647 #endif
18648         if ( exact ) {
18649             switch (OP(scan)) {
18650                 case EXACT:
18651                 case EXACTL:
18652                 case EXACTF:
18653                 case EXACTFA_NO_TRIE:
18654                 case EXACTFA:
18655                 case EXACTFU:
18656                 case EXACTFLU8:
18657                 case EXACTFU_SS:
18658                 case EXACTFL:
18659                         if( exact == PSEUDO )
18660                             exact= OP(scan);
18661                         else if ( exact != OP(scan) )
18662                             exact= 0;
18663                 case NOTHING:
18664                     break;
18665                 default:
18666                     exact= 0;
18667             }
18668         }
18669         DEBUG_PARSE_r({
18670             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
18671             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18672             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
18673                 SvPV_nolen_const(RExC_mysv),
18674                 REG_NODE_NUM(scan),
18675                 PL_reg_name[exact]);
18676         });
18677         if (temp == NULL)
18678             break;
18679         scan = temp;
18680     }
18681     DEBUG_PARSE_r({
18682         DEBUG_PARSE_MSG("");
18683         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
18684         Perl_re_printf( aTHX_
18685                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
18686                       SvPV_nolen_const(RExC_mysv),
18687                       (IV)REG_NODE_NUM(val),
18688                       (IV)(val - scan)
18689         );
18690     });
18691     if (reg_off_by_arg[OP(scan)]) {
18692         ARG_SET(scan, val - scan);
18693     }
18694     else {
18695         NEXT_OFF(scan) = val - scan;
18696     }
18697
18698     return exact;
18699 }
18700 #endif
18701
18702 /*
18703  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
18704  */
18705 #ifdef DEBUGGING
18706
18707 static void
18708 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
18709 {
18710     int bit;
18711     int set=0;
18712
18713     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18714
18715     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
18716         if (flags & (1<<bit)) {
18717             if (!set++ && lead)
18718                 Perl_re_printf( aTHX_  "%s",lead);
18719             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
18720         }
18721     }
18722     if (lead)  {
18723         if (set)
18724             Perl_re_printf( aTHX_  "\n");
18725         else
18726             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18727     }
18728 }
18729
18730 static void
18731 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
18732 {
18733     int bit;
18734     int set=0;
18735     regex_charset cs;
18736
18737     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18738
18739     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
18740         if (flags & (1<<bit)) {
18741             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
18742                 continue;
18743             }
18744             if (!set++ && lead)
18745                 Perl_re_printf( aTHX_  "%s",lead);
18746             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
18747         }
18748     }
18749     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
18750             if (!set++ && lead) {
18751                 Perl_re_printf( aTHX_  "%s",lead);
18752             }
18753             switch (cs) {
18754                 case REGEX_UNICODE_CHARSET:
18755                     Perl_re_printf( aTHX_  "UNICODE");
18756                     break;
18757                 case REGEX_LOCALE_CHARSET:
18758                     Perl_re_printf( aTHX_  "LOCALE");
18759                     break;
18760                 case REGEX_ASCII_RESTRICTED_CHARSET:
18761                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
18762                     break;
18763                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
18764                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
18765                     break;
18766                 default:
18767                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
18768                     break;
18769             }
18770     }
18771     if (lead)  {
18772         if (set)
18773             Perl_re_printf( aTHX_  "\n");
18774         else
18775             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18776     }
18777 }
18778 #endif
18779
18780 void
18781 Perl_regdump(pTHX_ const regexp *r)
18782 {
18783 #ifdef DEBUGGING
18784     SV * const sv = sv_newmortal();
18785     SV *dsv= sv_newmortal();
18786     RXi_GET_DECL(r,ri);
18787     GET_RE_DEBUG_FLAGS_DECL;
18788
18789     PERL_ARGS_ASSERT_REGDUMP;
18790
18791     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
18792
18793     /* Header fields of interest. */
18794     if (r->anchored_substr) {
18795         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
18796             RE_SV_DUMPLEN(r->anchored_substr), 30);
18797         Perl_re_printf( aTHX_
18798                       "anchored %s%s at %" IVdf " ",
18799                       s, RE_SV_TAIL(r->anchored_substr),
18800                       (IV)r->anchored_offset);
18801     } else if (r->anchored_utf8) {
18802         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
18803             RE_SV_DUMPLEN(r->anchored_utf8), 30);
18804         Perl_re_printf( aTHX_
18805                       "anchored utf8 %s%s at %" IVdf " ",
18806                       s, RE_SV_TAIL(r->anchored_utf8),
18807                       (IV)r->anchored_offset);
18808     }
18809     if (r->float_substr) {
18810         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
18811             RE_SV_DUMPLEN(r->float_substr), 30);
18812         Perl_re_printf( aTHX_
18813                       "floating %s%s at %" IVdf "..%" UVuf " ",
18814                       s, RE_SV_TAIL(r->float_substr),
18815                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18816     } else if (r->float_utf8) {
18817         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
18818             RE_SV_DUMPLEN(r->float_utf8), 30);
18819         Perl_re_printf( aTHX_
18820                       "floating utf8 %s%s at %" IVdf "..%" UVuf " ",
18821                       s, RE_SV_TAIL(r->float_utf8),
18822                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18823     }
18824     if (r->check_substr || r->check_utf8)
18825         Perl_re_printf( aTHX_
18826                       (const char *)
18827                       (r->check_substr == r->float_substr
18828                        && r->check_utf8 == r->float_utf8
18829                        ? "(checking floating" : "(checking anchored"));
18830     if (r->intflags & PREGf_NOSCAN)
18831         Perl_re_printf( aTHX_  " noscan");
18832     if (r->extflags & RXf_CHECK_ALL)
18833         Perl_re_printf( aTHX_  " isall");
18834     if (r->check_substr || r->check_utf8)
18835         Perl_re_printf( aTHX_  ") ");
18836
18837     if (ri->regstclass) {
18838         regprop(r, sv, ri->regstclass, NULL, NULL);
18839         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
18840     }
18841     if (r->intflags & PREGf_ANCH) {
18842         Perl_re_printf( aTHX_  "anchored");
18843         if (r->intflags & PREGf_ANCH_MBOL)
18844             Perl_re_printf( aTHX_  "(MBOL)");
18845         if (r->intflags & PREGf_ANCH_SBOL)
18846             Perl_re_printf( aTHX_  "(SBOL)");
18847         if (r->intflags & PREGf_ANCH_GPOS)
18848             Perl_re_printf( aTHX_  "(GPOS)");
18849         Perl_re_printf( aTHX_ " ");
18850     }
18851     if (r->intflags & PREGf_GPOS_SEEN)
18852         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
18853     if (r->intflags & PREGf_SKIP)
18854         Perl_re_printf( aTHX_  "plus ");
18855     if (r->intflags & PREGf_IMPLICIT)
18856         Perl_re_printf( aTHX_  "implicit ");
18857     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
18858     if (r->extflags & RXf_EVAL_SEEN)
18859         Perl_re_printf( aTHX_  "with eval ");
18860     Perl_re_printf( aTHX_  "\n");
18861     DEBUG_FLAGS_r({
18862         regdump_extflags("r->extflags: ",r->extflags);
18863         regdump_intflags("r->intflags: ",r->intflags);
18864     });
18865 #else
18866     PERL_ARGS_ASSERT_REGDUMP;
18867     PERL_UNUSED_CONTEXT;
18868     PERL_UNUSED_ARG(r);
18869 #endif  /* DEBUGGING */
18870 }
18871
18872 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
18873 #ifdef DEBUGGING
18874
18875 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
18876      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
18877      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
18878      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
18879      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
18880      || _CC_VERTSPACE != 15
18881 #   error Need to adjust order of anyofs[]
18882 #  endif
18883 static const char * const anyofs[] = {
18884     "\\w",
18885     "\\W",
18886     "\\d",
18887     "\\D",
18888     "[:alpha:]",
18889     "[:^alpha:]",
18890     "[:lower:]",
18891     "[:^lower:]",
18892     "[:upper:]",
18893     "[:^upper:]",
18894     "[:punct:]",
18895     "[:^punct:]",
18896     "[:print:]",
18897     "[:^print:]",
18898     "[:alnum:]",
18899     "[:^alnum:]",
18900     "[:graph:]",
18901     "[:^graph:]",
18902     "[:cased:]",
18903     "[:^cased:]",
18904     "\\s",
18905     "\\S",
18906     "[:blank:]",
18907     "[:^blank:]",
18908     "[:xdigit:]",
18909     "[:^xdigit:]",
18910     "[:cntrl:]",
18911     "[:^cntrl:]",
18912     "[:ascii:]",
18913     "[:^ascii:]",
18914     "\\v",
18915     "\\V"
18916 };
18917 #endif
18918
18919 /*
18920 - regprop - printable representation of opcode, with run time support
18921 */
18922
18923 void
18924 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
18925 {
18926 #ifdef DEBUGGING
18927     int k;
18928     RXi_GET_DECL(prog,progi);
18929     GET_RE_DEBUG_FLAGS_DECL;
18930
18931     PERL_ARGS_ASSERT_REGPROP;
18932
18933     SvPVCLEAR(sv);
18934
18935     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
18936         /* It would be nice to FAIL() here, but this may be called from
18937            regexec.c, and it would be hard to supply pRExC_state. */
18938         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
18939                                               (int)OP(o), (int)REGNODE_MAX);
18940     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
18941
18942     k = PL_regkind[OP(o)];
18943
18944     if (k == EXACT) {
18945         sv_catpvs(sv, " ");
18946         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
18947          * is a crude hack but it may be the best for now since
18948          * we have no flag "this EXACTish node was UTF-8"
18949          * --jhi */
18950         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
18951                   PERL_PV_ESCAPE_UNI_DETECT |
18952                   PERL_PV_ESCAPE_NONASCII   |
18953                   PERL_PV_PRETTY_ELLIPSES   |
18954                   PERL_PV_PRETTY_LTGT       |
18955                   PERL_PV_PRETTY_NOCLEAR
18956                   );
18957     } else if (k == TRIE) {
18958         /* print the details of the trie in dumpuntil instead, as
18959          * progi->data isn't available here */
18960         const char op = OP(o);
18961         const U32 n = ARG(o);
18962         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
18963                (reg_ac_data *)progi->data->data[n] :
18964                NULL;
18965         const reg_trie_data * const trie
18966             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
18967
18968         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
18969         DEBUG_TRIE_COMPILE_r({
18970           if (trie->jump)
18971             sv_catpvs(sv, "(JUMP)");
18972           Perl_sv_catpvf(aTHX_ sv,
18973             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
18974             (UV)trie->startstate,
18975             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
18976             (UV)trie->wordcount,
18977             (UV)trie->minlen,
18978             (UV)trie->maxlen,
18979             (UV)TRIE_CHARCOUNT(trie),
18980             (UV)trie->uniquecharcount
18981           );
18982         });
18983         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
18984             sv_catpvs(sv, "[");
18985             (void) put_charclass_bitmap_innards(sv,
18986                                                 ((IS_ANYOF_TRIE(op))
18987                                                  ? ANYOF_BITMAP(o)
18988                                                  : TRIE_BITMAP(trie)),
18989                                                 NULL,
18990                                                 NULL,
18991                                                 NULL,
18992                                                 FALSE
18993                                                );
18994             sv_catpvs(sv, "]");
18995         }
18996     } else if (k == CURLY) {
18997         U32 lo = ARG1(o), hi = ARG2(o);
18998         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
18999             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
19000         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
19001         if (hi == REG_INFTY)
19002             sv_catpvs(sv, "INFTY");
19003         else
19004             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
19005         sv_catpvs(sv, "}");
19006     }
19007     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
19008         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
19009     else if (k == REF || k == OPEN || k == CLOSE
19010              || k == GROUPP || OP(o)==ACCEPT)
19011     {
19012         AV *name_list= NULL;
19013         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
19014         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
19015         if ( RXp_PAREN_NAMES(prog) ) {
19016             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19017         } else if ( pRExC_state ) {
19018             name_list= RExC_paren_name_list;
19019         }
19020         if (name_list) {
19021             if ( k != REF || (OP(o) < NREF)) {
19022                 SV **name= av_fetch(name_list, parno, 0 );
19023                 if (name)
19024                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19025             }
19026             else {
19027                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
19028                 I32 *nums=(I32*)SvPVX(sv_dat);
19029                 SV **name= av_fetch(name_list, nums[0], 0 );
19030                 I32 n;
19031                 if (name) {
19032                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
19033                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
19034                                     (n ? "," : ""), (IV)nums[n]);
19035                     }
19036                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19037                 }
19038             }
19039         }
19040         if ( k == REF && reginfo) {
19041             U32 n = ARG(o);  /* which paren pair */
19042             I32 ln = prog->offs[n].start;
19043             if (prog->lastparen < n || ln == -1)
19044                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
19045             else if (ln == prog->offs[n].end)
19046                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
19047             else {
19048                 const char *s = reginfo->strbeg + ln;
19049                 Perl_sv_catpvf(aTHX_ sv, ": ");
19050                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
19051                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
19052             }
19053         }
19054     } else if (k == GOSUB) {
19055         AV *name_list= NULL;
19056         if ( RXp_PAREN_NAMES(prog) ) {
19057             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19058         } else if ( pRExC_state ) {
19059             name_list= RExC_paren_name_list;
19060         }
19061
19062         /* Paren and offset */
19063         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
19064                 (int)((o + (int)ARG2L(o)) - progi->program) );
19065         if (name_list) {
19066             SV **name= av_fetch(name_list, ARG(o), 0 );
19067             if (name)
19068                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19069         }
19070     }
19071     else if (k == LOGICAL)
19072         /* 2: embedded, otherwise 1 */
19073         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
19074     else if (k == ANYOF) {
19075         const U8 flags = ANYOF_FLAGS(o);
19076         bool do_sep = FALSE;    /* Do we need to separate various components of
19077                                    the output? */
19078         /* Set if there is still an unresolved user-defined property */
19079         SV *unresolved                = NULL;
19080
19081         /* Things that are ignored except when the runtime locale is UTF-8 */
19082         SV *only_utf8_locale_invlist = NULL;
19083
19084         /* Code points that don't fit in the bitmap */
19085         SV *nonbitmap_invlist = NULL;
19086
19087         /* And things that aren't in the bitmap, but are small enough to be */
19088         SV* bitmap_range_not_in_bitmap = NULL;
19089
19090         const bool inverted = flags & ANYOF_INVERT;
19091
19092         if (OP(o) == ANYOFL) {
19093             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
19094                 sv_catpvs(sv, "{utf8-locale-reqd}");
19095             }
19096             if (flags & ANYOFL_FOLD) {
19097                 sv_catpvs(sv, "{i}");
19098             }
19099         }
19100
19101         /* If there is stuff outside the bitmap, get it */
19102         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
19103             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
19104                                                 &unresolved,
19105                                                 &only_utf8_locale_invlist,
19106                                                 &nonbitmap_invlist);
19107             /* The non-bitmap data may contain stuff that could fit in the
19108              * bitmap.  This could come from a user-defined property being
19109              * finally resolved when this call was done; or much more likely
19110              * because there are matches that require UTF-8 to be valid, and so
19111              * aren't in the bitmap.  This is teased apart later */
19112             _invlist_intersection(nonbitmap_invlist,
19113                                   PL_InBitmap,
19114                                   &bitmap_range_not_in_bitmap);
19115             /* Leave just the things that don't fit into the bitmap */
19116             _invlist_subtract(nonbitmap_invlist,
19117                               PL_InBitmap,
19118                               &nonbitmap_invlist);
19119         }
19120
19121         /* Obey this flag to add all above-the-bitmap code points */
19122         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
19123             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
19124                                                       NUM_ANYOF_CODE_POINTS,
19125                                                       UV_MAX);
19126         }
19127
19128         /* Ready to start outputting.  First, the initial left bracket */
19129         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19130
19131         /* Then all the things that could fit in the bitmap */
19132         do_sep = put_charclass_bitmap_innards(sv,
19133                                               ANYOF_BITMAP(o),
19134                                               bitmap_range_not_in_bitmap,
19135                                               only_utf8_locale_invlist,
19136                                               o,
19137
19138                                               /* Can't try inverting for a
19139                                                * better display if there are
19140                                                * things that haven't been
19141                                                * resolved */
19142                                               unresolved != NULL);
19143         SvREFCNT_dec(bitmap_range_not_in_bitmap);
19144
19145         /* If there are user-defined properties which haven't been defined yet,
19146          * output them.  If the result is not to be inverted, it is clearest to
19147          * output them in a separate [] from the bitmap range stuff.  If the
19148          * result is to be complemented, we have to show everything in one [],
19149          * as the inversion applies to the whole thing.  Use {braces} to
19150          * separate them from anything in the bitmap and anything above the
19151          * bitmap. */
19152         if (unresolved) {
19153             if (inverted) {
19154                 if (! do_sep) { /* If didn't output anything in the bitmap */
19155                     sv_catpvs(sv, "^");
19156                 }
19157                 sv_catpvs(sv, "{");
19158             }
19159             else if (do_sep) {
19160                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19161             }
19162             sv_catsv(sv, unresolved);
19163             if (inverted) {
19164                 sv_catpvs(sv, "}");
19165             }
19166             do_sep = ! inverted;
19167         }
19168
19169         /* And, finally, add the above-the-bitmap stuff */
19170         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
19171             SV* contents;
19172
19173             /* See if truncation size is overridden */
19174             const STRLEN dump_len = (PL_dump_re_max_len)
19175                                     ? PL_dump_re_max_len
19176                                     : 256;
19177
19178             /* This is output in a separate [] */
19179             if (do_sep) {
19180                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19181             }
19182
19183             /* And, for easy of understanding, it is shown in the
19184              * uncomplemented form if possible.  The one exception being if
19185              * there are unresolved items, where the inversion has to be
19186              * delayed until runtime */
19187             if (inverted && ! unresolved) {
19188                 _invlist_invert(nonbitmap_invlist);
19189                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
19190             }
19191
19192             contents = invlist_contents(nonbitmap_invlist,
19193                                         FALSE /* output suitable for catsv */
19194                                        );
19195
19196             /* If the output is shorter than the permissible maximum, just do it. */
19197             if (SvCUR(contents) <= dump_len) {
19198                 sv_catsv(sv, contents);
19199             }
19200             else {
19201                 const char * contents_string = SvPVX(contents);
19202                 STRLEN i = dump_len;
19203
19204                 /* Otherwise, start at the permissible max and work back to the
19205                  * first break possibility */
19206                 while (i > 0 && contents_string[i] != ' ') {
19207                     i--;
19208                 }
19209                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
19210                                        find a legal break */
19211                     i = dump_len;
19212                 }
19213
19214                 sv_catpvn(sv, contents_string, i);
19215                 sv_catpvs(sv, "...");
19216             }
19217
19218             SvREFCNT_dec_NN(contents);
19219             SvREFCNT_dec_NN(nonbitmap_invlist);
19220         }
19221
19222         /* And finally the matching, closing ']' */
19223         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19224
19225         SvREFCNT_dec(unresolved);
19226     }
19227     else if (k == POSIXD || k == NPOSIXD) {
19228         U8 index = FLAGS(o) * 2;
19229         if (index < C_ARRAY_LENGTH(anyofs)) {
19230             if (*anyofs[index] != '[')  {
19231                 sv_catpv(sv, "[");
19232             }
19233             sv_catpv(sv, anyofs[index]);
19234             if (*anyofs[index] != '[')  {
19235                 sv_catpv(sv, "]");
19236             }
19237         }
19238         else {
19239             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
19240         }
19241     }
19242     else if (k == BOUND || k == NBOUND) {
19243         /* Must be synced with order of 'bound_type' in regcomp.h */
19244         const char * const bounds[] = {
19245             "",      /* Traditional */
19246             "{gcb}",
19247             "{lb}",
19248             "{sb}",
19249             "{wb}"
19250         };
19251         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
19252         sv_catpv(sv, bounds[FLAGS(o)]);
19253     }
19254     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
19255         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
19256     else if (OP(o) == SBOL)
19257         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
19258
19259     /* add on the verb argument if there is one */
19260     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
19261         Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
19262                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
19263     }
19264 #else
19265     PERL_UNUSED_CONTEXT;
19266     PERL_UNUSED_ARG(sv);
19267     PERL_UNUSED_ARG(o);
19268     PERL_UNUSED_ARG(prog);
19269     PERL_UNUSED_ARG(reginfo);
19270     PERL_UNUSED_ARG(pRExC_state);
19271 #endif  /* DEBUGGING */
19272 }
19273
19274
19275
19276 SV *
19277 Perl_re_intuit_string(pTHX_ REGEXP * const r)
19278 {                               /* Assume that RE_INTUIT is set */
19279     struct regexp *const prog = ReANY(r);
19280     GET_RE_DEBUG_FLAGS_DECL;
19281
19282     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
19283     PERL_UNUSED_CONTEXT;
19284
19285     DEBUG_COMPILE_r(
19286         {
19287             const char * const s = SvPV_nolen_const(RX_UTF8(r)
19288                       ? prog->check_utf8 : prog->check_substr);
19289
19290             if (!PL_colorset) reginitcolors();
19291             Perl_re_printf( aTHX_
19292                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
19293                       PL_colors[4],
19294                       RX_UTF8(r) ? "utf8 " : "",
19295                       PL_colors[5],PL_colors[0],
19296                       s,
19297                       PL_colors[1],
19298                       (strlen(s) > 60 ? "..." : ""));
19299         } );
19300
19301     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
19302     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
19303 }
19304
19305 /*
19306    pregfree()
19307
19308    handles refcounting and freeing the perl core regexp structure. When
19309    it is necessary to actually free the structure the first thing it
19310    does is call the 'free' method of the regexp_engine associated to
19311    the regexp, allowing the handling of the void *pprivate; member
19312    first. (This routine is not overridable by extensions, which is why
19313    the extensions free is called first.)
19314
19315    See regdupe and regdupe_internal if you change anything here.
19316 */
19317 #ifndef PERL_IN_XSUB_RE
19318 void
19319 Perl_pregfree(pTHX_ REGEXP *r)
19320 {
19321     SvREFCNT_dec(r);
19322 }
19323
19324 void
19325 Perl_pregfree2(pTHX_ REGEXP *rx)
19326 {
19327     struct regexp *const r = ReANY(rx);
19328     GET_RE_DEBUG_FLAGS_DECL;
19329
19330     PERL_ARGS_ASSERT_PREGFREE2;
19331
19332     if (r->mother_re) {
19333         ReREFCNT_dec(r->mother_re);
19334     } else {
19335         CALLREGFREE_PVT(rx); /* free the private data */
19336         SvREFCNT_dec(RXp_PAREN_NAMES(r));
19337         Safefree(r->xpv_len_u.xpvlenu_pv);
19338     }
19339     if (r->substrs) {
19340         SvREFCNT_dec(r->anchored_substr);
19341         SvREFCNT_dec(r->anchored_utf8);
19342         SvREFCNT_dec(r->float_substr);
19343         SvREFCNT_dec(r->float_utf8);
19344         Safefree(r->substrs);
19345     }
19346     RX_MATCH_COPY_FREE(rx);
19347 #ifdef PERL_ANY_COW
19348     SvREFCNT_dec(r->saved_copy);
19349 #endif
19350     Safefree(r->offs);
19351     SvREFCNT_dec(r->qr_anoncv);
19352     if (r->recurse_locinput)
19353         Safefree(r->recurse_locinput);
19354     rx->sv_u.svu_rx = 0;
19355 }
19356
19357 /*  reg_temp_copy()
19358
19359     This is a hacky workaround to the structural issue of match results
19360     being stored in the regexp structure which is in turn stored in
19361     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
19362     could be PL_curpm in multiple contexts, and could require multiple
19363     result sets being associated with the pattern simultaneously, such
19364     as when doing a recursive match with (??{$qr})
19365
19366     The solution is to make a lightweight copy of the regexp structure
19367     when a qr// is returned from the code executed by (??{$qr}) this
19368     lightweight copy doesn't actually own any of its data except for
19369     the starp/end and the actual regexp structure itself.
19370
19371 */
19372
19373
19374 REGEXP *
19375 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
19376 {
19377     struct regexp *ret;
19378     struct regexp *const r = ReANY(rx);
19379     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
19380
19381     PERL_ARGS_ASSERT_REG_TEMP_COPY;
19382
19383     if (!ret_x)
19384         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
19385     else {
19386         SvOK_off((SV *)ret_x);
19387         if (islv) {
19388             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
19389                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
19390                made both spots point to the same regexp body.) */
19391             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
19392             assert(!SvPVX(ret_x));
19393             ret_x->sv_u.svu_rx = temp->sv_any;
19394             temp->sv_any = NULL;
19395             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
19396             SvREFCNT_dec_NN(temp);
19397             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
19398                ing below will not set it. */
19399             SvCUR_set(ret_x, SvCUR(rx));
19400         }
19401     }
19402     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
19403        sv_force_normal(sv) is called.  */
19404     SvFAKE_on(ret_x);
19405     ret = ReANY(ret_x);
19406
19407     SvFLAGS(ret_x) |= SvUTF8(rx);
19408     /* We share the same string buffer as the original regexp, on which we
19409        hold a reference count, incremented when mother_re is set below.
19410        The string pointer is copied here, being part of the regexp struct.
19411      */
19412     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
19413            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
19414     if (r->offs) {
19415         const I32 npar = r->nparens+1;
19416         Newx(ret->offs, npar, regexp_paren_pair);
19417         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19418     }
19419     if (r->substrs) {
19420         Newx(ret->substrs, 1, struct reg_substr_data);
19421         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19422
19423         SvREFCNT_inc_void(ret->anchored_substr);
19424         SvREFCNT_inc_void(ret->anchored_utf8);
19425         SvREFCNT_inc_void(ret->float_substr);
19426         SvREFCNT_inc_void(ret->float_utf8);
19427
19428         /* check_substr and check_utf8, if non-NULL, point to either their
19429            anchored or float namesakes, and don't hold a second reference.  */
19430     }
19431     RX_MATCH_COPIED_off(ret_x);
19432 #ifdef PERL_ANY_COW
19433     ret->saved_copy = NULL;
19434 #endif
19435     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
19436     SvREFCNT_inc_void(ret->qr_anoncv);
19437     if (r->recurse_locinput)
19438         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19439
19440     return ret_x;
19441 }
19442 #endif
19443
19444 /* regfree_internal()
19445
19446    Free the private data in a regexp. This is overloadable by
19447    extensions. Perl takes care of the regexp structure in pregfree(),
19448    this covers the *pprivate pointer which technically perl doesn't
19449    know about, however of course we have to handle the
19450    regexp_internal structure when no extension is in use.
19451
19452    Note this is called before freeing anything in the regexp
19453    structure.
19454  */
19455
19456 void
19457 Perl_regfree_internal(pTHX_ REGEXP * const rx)
19458 {
19459     struct regexp *const r = ReANY(rx);
19460     RXi_GET_DECL(r,ri);
19461     GET_RE_DEBUG_FLAGS_DECL;
19462
19463     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
19464
19465     DEBUG_COMPILE_r({
19466         if (!PL_colorset)
19467             reginitcolors();
19468         {
19469             SV *dsv= sv_newmortal();
19470             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
19471                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
19472             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
19473                 PL_colors[4],PL_colors[5],s);
19474         }
19475     });
19476 #ifdef RE_TRACK_PATTERN_OFFSETS
19477     if (ri->u.offsets)
19478         Safefree(ri->u.offsets);             /* 20010421 MJD */
19479 #endif
19480     if (ri->code_blocks) {
19481         int n;
19482         for (n = 0; n < ri->num_code_blocks; n++)
19483             SvREFCNT_dec(ri->code_blocks[n].src_regex);
19484         Safefree(ri->code_blocks);
19485     }
19486
19487     if (ri->data) {
19488         int n = ri->data->count;
19489
19490         while (--n >= 0) {
19491           /* If you add a ->what type here, update the comment in regcomp.h */
19492             switch (ri->data->what[n]) {
19493             case 'a':
19494             case 'r':
19495             case 's':
19496             case 'S':
19497             case 'u':
19498                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
19499                 break;
19500             case 'f':
19501                 Safefree(ri->data->data[n]);
19502                 break;
19503             case 'l':
19504             case 'L':
19505                 break;
19506             case 'T':
19507                 { /* Aho Corasick add-on structure for a trie node.
19508                      Used in stclass optimization only */
19509                     U32 refcount;
19510                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
19511 #ifdef USE_ITHREADS
19512                     dVAR;
19513 #endif
19514                     OP_REFCNT_LOCK;
19515                     refcount = --aho->refcount;
19516                     OP_REFCNT_UNLOCK;
19517                     if ( !refcount ) {
19518                         PerlMemShared_free(aho->states);
19519                         PerlMemShared_free(aho->fail);
19520                          /* do this last!!!! */
19521                         PerlMemShared_free(ri->data->data[n]);
19522                         /* we should only ever get called once, so
19523                          * assert as much, and also guard the free
19524                          * which /might/ happen twice. At the least
19525                          * it will make code anlyzers happy and it
19526                          * doesn't cost much. - Yves */
19527                         assert(ri->regstclass);
19528                         if (ri->regstclass) {
19529                             PerlMemShared_free(ri->regstclass);
19530                             ri->regstclass = 0;
19531                         }
19532                     }
19533                 }
19534                 break;
19535             case 't':
19536                 {
19537                     /* trie structure. */
19538                     U32 refcount;
19539                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
19540 #ifdef USE_ITHREADS
19541                     dVAR;
19542 #endif
19543                     OP_REFCNT_LOCK;
19544                     refcount = --trie->refcount;
19545                     OP_REFCNT_UNLOCK;
19546                     if ( !refcount ) {
19547                         PerlMemShared_free(trie->charmap);
19548                         PerlMemShared_free(trie->states);
19549                         PerlMemShared_free(trie->trans);
19550                         if (trie->bitmap)
19551                             PerlMemShared_free(trie->bitmap);
19552                         if (trie->jump)
19553                             PerlMemShared_free(trie->jump);
19554                         PerlMemShared_free(trie->wordinfo);
19555                         /* do this last!!!! */
19556                         PerlMemShared_free(ri->data->data[n]);
19557                     }
19558                 }
19559                 break;
19560             default:
19561                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
19562                                                     ri->data->what[n]);
19563             }
19564         }
19565         Safefree(ri->data->what);
19566         Safefree(ri->data);
19567     }
19568
19569     Safefree(ri);
19570 }
19571
19572 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
19573 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
19574 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
19575
19576 /*
19577    re_dup_guts - duplicate a regexp.
19578
19579    This routine is expected to clone a given regexp structure. It is only
19580    compiled under USE_ITHREADS.
19581
19582    After all of the core data stored in struct regexp is duplicated
19583    the regexp_engine.dupe method is used to copy any private data
19584    stored in the *pprivate pointer. This allows extensions to handle
19585    any duplication it needs to do.
19586
19587    See pregfree() and regfree_internal() if you change anything here.
19588 */
19589 #if defined(USE_ITHREADS)
19590 #ifndef PERL_IN_XSUB_RE
19591 void
19592 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
19593 {
19594     dVAR;
19595     I32 npar;
19596     const struct regexp *r = ReANY(sstr);
19597     struct regexp *ret = ReANY(dstr);
19598
19599     PERL_ARGS_ASSERT_RE_DUP_GUTS;
19600
19601     npar = r->nparens+1;
19602     Newx(ret->offs, npar, regexp_paren_pair);
19603     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19604
19605     if (ret->substrs) {
19606         /* Do it this way to avoid reading from *r after the StructCopy().
19607            That way, if any of the sv_dup_inc()s dislodge *r from the L1
19608            cache, it doesn't matter.  */
19609         const bool anchored = r->check_substr
19610             ? r->check_substr == r->anchored_substr
19611             : r->check_utf8 == r->anchored_utf8;
19612         Newx(ret->substrs, 1, struct reg_substr_data);
19613         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19614
19615         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
19616         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
19617         ret->float_substr = sv_dup_inc(ret->float_substr, param);
19618         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
19619
19620         /* check_substr and check_utf8, if non-NULL, point to either their
19621            anchored or float namesakes, and don't hold a second reference.  */
19622
19623         if (ret->check_substr) {
19624             if (anchored) {
19625                 assert(r->check_utf8 == r->anchored_utf8);
19626                 ret->check_substr = ret->anchored_substr;
19627                 ret->check_utf8 = ret->anchored_utf8;
19628             } else {
19629                 assert(r->check_substr == r->float_substr);
19630                 assert(r->check_utf8 == r->float_utf8);
19631                 ret->check_substr = ret->float_substr;
19632                 ret->check_utf8 = ret->float_utf8;
19633             }
19634         } else if (ret->check_utf8) {
19635             if (anchored) {
19636                 ret->check_utf8 = ret->anchored_utf8;
19637             } else {
19638                 ret->check_utf8 = ret->float_utf8;
19639             }
19640         }
19641     }
19642
19643     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
19644     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
19645     if (r->recurse_locinput)
19646         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19647
19648     if (ret->pprivate)
19649         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
19650
19651     if (RX_MATCH_COPIED(dstr))
19652         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
19653     else
19654         ret->subbeg = NULL;
19655 #ifdef PERL_ANY_COW
19656     ret->saved_copy = NULL;
19657 #endif
19658
19659     /* Whether mother_re be set or no, we need to copy the string.  We
19660        cannot refrain from copying it when the storage points directly to
19661        our mother regexp, because that's
19662                1: a buffer in a different thread
19663                2: something we no longer hold a reference on
19664                so we need to copy it locally.  */
19665     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
19666     ret->mother_re   = NULL;
19667 }
19668 #endif /* PERL_IN_XSUB_RE */
19669
19670 /*
19671    regdupe_internal()
19672
19673    This is the internal complement to regdupe() which is used to copy
19674    the structure pointed to by the *pprivate pointer in the regexp.
19675    This is the core version of the extension overridable cloning hook.
19676    The regexp structure being duplicated will be copied by perl prior
19677    to this and will be provided as the regexp *r argument, however
19678    with the /old/ structures pprivate pointer value. Thus this routine
19679    may override any copying normally done by perl.
19680
19681    It returns a pointer to the new regexp_internal structure.
19682 */
19683
19684 void *
19685 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
19686 {
19687     dVAR;
19688     struct regexp *const r = ReANY(rx);
19689     regexp_internal *reti;
19690     int len;
19691     RXi_GET_DECL(r,ri);
19692
19693     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
19694
19695     len = ProgLen(ri);
19696
19697     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
19698           char, regexp_internal);
19699     Copy(ri->program, reti->program, len+1, regnode);
19700
19701
19702     reti->num_code_blocks = ri->num_code_blocks;
19703     if (ri->code_blocks) {
19704         int n;
19705         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
19706                 struct reg_code_block);
19707         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
19708                 struct reg_code_block);
19709         for (n = 0; n < ri->num_code_blocks; n++)
19710              reti->code_blocks[n].src_regex = (REGEXP*)
19711                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
19712     }
19713     else
19714         reti->code_blocks = NULL;
19715
19716     reti->regstclass = NULL;
19717
19718     if (ri->data) {
19719         struct reg_data *d;
19720         const int count = ri->data->count;
19721         int i;
19722
19723         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
19724                 char, struct reg_data);
19725         Newx(d->what, count, U8);
19726
19727         d->count = count;
19728         for (i = 0; i < count; i++) {
19729             d->what[i] = ri->data->what[i];
19730             switch (d->what[i]) {
19731                 /* see also regcomp.h and regfree_internal() */
19732             case 'a': /* actually an AV, but the dup function is identical.  */
19733             case 'r':
19734             case 's':
19735             case 'S':
19736             case 'u': /* actually an HV, but the dup function is identical.  */
19737                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
19738                 break;
19739             case 'f':
19740                 /* This is cheating. */
19741                 Newx(d->data[i], 1, regnode_ssc);
19742                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
19743                 reti->regstclass = (regnode*)d->data[i];
19744                 break;
19745             case 'T':
19746                 /* Trie stclasses are readonly and can thus be shared
19747                  * without duplication. We free the stclass in pregfree
19748                  * when the corresponding reg_ac_data struct is freed.
19749                  */
19750                 reti->regstclass= ri->regstclass;
19751                 /* FALLTHROUGH */
19752             case 't':
19753                 OP_REFCNT_LOCK;
19754                 ((reg_trie_data*)ri->data->data[i])->refcount++;
19755                 OP_REFCNT_UNLOCK;
19756                 /* FALLTHROUGH */
19757             case 'l':
19758             case 'L':
19759                 d->data[i] = ri->data->data[i];
19760                 break;
19761             default:
19762                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
19763                                                            ri->data->what[i]);
19764             }
19765         }
19766
19767         reti->data = d;
19768     }
19769     else
19770         reti->data = NULL;
19771
19772     reti->name_list_idx = ri->name_list_idx;
19773
19774 #ifdef RE_TRACK_PATTERN_OFFSETS
19775     if (ri->u.offsets) {
19776         Newx(reti->u.offsets, 2*len+1, U32);
19777         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
19778     }
19779 #else
19780     SetProgLen(reti,len);
19781 #endif
19782
19783     return (void*)reti;
19784 }
19785
19786 #endif    /* USE_ITHREADS */
19787
19788 #ifndef PERL_IN_XSUB_RE
19789
19790 /*
19791  - regnext - dig the "next" pointer out of a node
19792  */
19793 regnode *
19794 Perl_regnext(pTHX_ regnode *p)
19795 {
19796     I32 offset;
19797
19798     if (!p)
19799         return(NULL);
19800
19801     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
19802         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19803                                                 (int)OP(p), (int)REGNODE_MAX);
19804     }
19805
19806     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
19807     if (offset == 0)
19808         return(NULL);
19809
19810     return(p+offset);
19811 }
19812 #endif
19813
19814 STATIC void
19815 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
19816 {
19817     va_list args;
19818     STRLEN l1 = strlen(pat1);
19819     STRLEN l2 = strlen(pat2);
19820     char buf[512];
19821     SV *msv;
19822     const char *message;
19823
19824     PERL_ARGS_ASSERT_RE_CROAK2;
19825
19826     if (l1 > 510)
19827         l1 = 510;
19828     if (l1 + l2 > 510)
19829         l2 = 510 - l1;
19830     Copy(pat1, buf, l1 , char);
19831     Copy(pat2, buf + l1, l2 , char);
19832     buf[l1 + l2] = '\n';
19833     buf[l1 + l2 + 1] = '\0';
19834     va_start(args, pat2);
19835     msv = vmess(buf, &args);
19836     va_end(args);
19837     message = SvPV_const(msv,l1);
19838     if (l1 > 512)
19839         l1 = 512;
19840     Copy(message, buf, l1 , char);
19841     /* l1-1 to avoid \n */
19842     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
19843 }
19844
19845 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
19846
19847 #ifndef PERL_IN_XSUB_RE
19848 void
19849 Perl_save_re_context(pTHX)
19850 {
19851     I32 nparens = -1;
19852     I32 i;
19853
19854     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
19855
19856     if (PL_curpm) {
19857         const REGEXP * const rx = PM_GETRE(PL_curpm);
19858         if (rx)
19859             nparens = RX_NPARENS(rx);
19860     }
19861
19862     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
19863      * that PL_curpm will be null, but that utf8.pm and the modules it
19864      * loads will only use $1..$3.
19865      * The t/porting/re_context.t test file checks this assumption.
19866      */
19867     if (nparens == -1)
19868         nparens = 3;
19869
19870     for (i = 1; i <= nparens; i++) {
19871         char digits[TYPE_CHARS(long)];
19872         const STRLEN len = my_snprintf(digits, sizeof(digits),
19873                                        "%lu", (long)i);
19874         GV *const *const gvp
19875             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
19876
19877         if (gvp) {
19878             GV * const gv = *gvp;
19879             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
19880                 save_scalar(gv);
19881         }
19882     }
19883 }
19884 #endif
19885
19886 #ifdef DEBUGGING
19887
19888 STATIC void
19889 S_put_code_point(pTHX_ SV *sv, UV c)
19890 {
19891     PERL_ARGS_ASSERT_PUT_CODE_POINT;
19892
19893     if (c > 255) {
19894         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
19895     }
19896     else if (isPRINT(c)) {
19897         const char string = (char) c;
19898
19899         /* We use {phrase} as metanotation in the class, so also escape literal
19900          * braces */
19901         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
19902             sv_catpvs(sv, "\\");
19903         sv_catpvn(sv, &string, 1);
19904     }
19905     else if (isMNEMONIC_CNTRL(c)) {
19906         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
19907     }
19908     else {
19909         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
19910     }
19911 }
19912
19913 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
19914
19915 STATIC void
19916 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
19917 {
19918     /* Appends to 'sv' a displayable version of the range of code points from
19919      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
19920      * that have them, when they occur at the beginning or end of the range.
19921      * It uses hex to output the remaining code points, unless 'allow_literals'
19922      * is true, in which case the printable ASCII ones are output as-is (though
19923      * some of these will be escaped by put_code_point()).
19924      *
19925      * NOTE:  This is designed only for printing ranges of code points that fit
19926      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
19927      */
19928
19929     const unsigned int min_range_count = 3;
19930
19931     assert(start <= end);
19932
19933     PERL_ARGS_ASSERT_PUT_RANGE;
19934
19935     while (start <= end) {
19936         UV this_end;
19937         const char * format;
19938
19939         if (end - start < min_range_count) {
19940
19941             /* Output chars individually when they occur in short ranges */
19942             for (; start <= end; start++) {
19943                 put_code_point(sv, start);
19944             }
19945             break;
19946         }
19947
19948         /* If permitted by the input options, and there is a possibility that
19949          * this range contains a printable literal, look to see if there is
19950          * one. */
19951         if (allow_literals && start <= MAX_PRINT_A) {
19952
19953             /* If the character at the beginning of the range isn't an ASCII
19954              * printable, effectively split the range into two parts:
19955              *  1) the portion before the first such printable,
19956              *  2) the rest
19957              * and output them separately. */
19958             if (! isPRINT_A(start)) {
19959                 UV temp_end = start + 1;
19960
19961                 /* There is no point looking beyond the final possible
19962                  * printable, in MAX_PRINT_A */
19963                 UV max = MIN(end, MAX_PRINT_A);
19964
19965                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
19966                     temp_end++;
19967                 }
19968
19969                 /* Here, temp_end points to one beyond the first printable if
19970                  * found, or to one beyond 'max' if not.  If none found, make
19971                  * sure that we use the entire range */
19972                 if (temp_end > MAX_PRINT_A) {
19973                     temp_end = end + 1;
19974                 }
19975
19976                 /* Output the first part of the split range: the part that
19977                  * doesn't have printables, with the parameter set to not look
19978                  * for literals (otherwise we would infinitely recurse) */
19979                 put_range(sv, start, temp_end - 1, FALSE);
19980
19981                 /* The 2nd part of the range (if any) starts here. */
19982                 start = temp_end;
19983
19984                 /* We do a continue, instead of dropping down, because even if
19985                  * the 2nd part is non-empty, it could be so short that we want
19986                  * to output it as individual characters, as tested for at the
19987                  * top of this loop.  */
19988                 continue;
19989             }
19990
19991             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
19992              * output a sub-range of just the digits or letters, then process
19993              * the remaining portion as usual. */
19994             if (isALPHANUMERIC_A(start)) {
19995                 UV mask = (isDIGIT_A(start))
19996                            ? _CC_DIGIT
19997                              : isUPPER_A(start)
19998                                ? _CC_UPPER
19999                                : _CC_LOWER;
20000                 UV temp_end = start + 1;
20001
20002                 /* Find the end of the sub-range that includes just the
20003                  * characters in the same class as the first character in it */
20004                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
20005                     temp_end++;
20006                 }
20007                 temp_end--;
20008
20009                 /* For short ranges, don't duplicate the code above to output
20010                  * them; just call recursively */
20011                 if (temp_end - start < min_range_count) {
20012                     put_range(sv, start, temp_end, FALSE);
20013                 }
20014                 else {  /* Output as a range */
20015                     put_code_point(sv, start);
20016                     sv_catpvs(sv, "-");
20017                     put_code_point(sv, temp_end);
20018                 }
20019                 start = temp_end + 1;
20020                 continue;
20021             }
20022
20023             /* We output any other printables as individual characters */
20024             if (isPUNCT_A(start) || isSPACE_A(start)) {
20025                 while (start <= end && (isPUNCT_A(start)
20026                                         || isSPACE_A(start)))
20027                 {
20028                     put_code_point(sv, start);
20029                     start++;
20030                 }
20031                 continue;
20032             }
20033         } /* End of looking for literals */
20034
20035         /* Here is not to output as a literal.  Some control characters have
20036          * mnemonic names.  Split off any of those at the beginning and end of
20037          * the range to print mnemonically.  It isn't possible for many of
20038          * these to be in a row, so this won't overwhelm with output */
20039         if (   start <= end
20040             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
20041         {
20042             while (isMNEMONIC_CNTRL(start) && start <= end) {
20043                 put_code_point(sv, start);
20044                 start++;
20045             }
20046
20047             /* If this didn't take care of the whole range ... */
20048             if (start <= end) {
20049
20050                 /* Look backwards from the end to find the final non-mnemonic
20051                  * */
20052                 UV temp_end = end;
20053                 while (isMNEMONIC_CNTRL(temp_end)) {
20054                     temp_end--;
20055                 }
20056
20057                 /* And separately output the interior range that doesn't start
20058                  * or end with mnemonics */
20059                 put_range(sv, start, temp_end, FALSE);
20060
20061                 /* Then output the mnemonic trailing controls */
20062                 start = temp_end + 1;
20063                 while (start <= end) {
20064                     put_code_point(sv, start);
20065                     start++;
20066                 }
20067                 break;
20068             }
20069         }
20070
20071         /* As a final resort, output the range or subrange as hex. */
20072
20073         this_end = (end < NUM_ANYOF_CODE_POINTS)
20074                     ? end
20075                     : NUM_ANYOF_CODE_POINTS - 1;
20076 #if NUM_ANYOF_CODE_POINTS > 256
20077         format = (this_end < 256)
20078                  ? "\\x%02" UVXf "-\\x%02" UVXf
20079                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
20080 #else
20081         format = "\\x%02" UVXf "-\\x%02" UVXf;
20082 #endif
20083         GCC_DIAG_IGNORE(-Wformat-nonliteral);
20084         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
20085         GCC_DIAG_RESTORE;
20086         break;
20087     }
20088 }
20089
20090 STATIC void
20091 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
20092 {
20093     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
20094      * 'invlist' */
20095
20096     UV start, end;
20097     bool allow_literals = TRUE;
20098
20099     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
20100
20101     /* Generally, it is more readable if printable characters are output as
20102      * literals, but if a range (nearly) spans all of them, it's best to output
20103      * it as a single range.  This code will use a single range if all but 2
20104      * ASCII printables are in it */
20105     invlist_iterinit(invlist);
20106     while (invlist_iternext(invlist, &start, &end)) {
20107
20108         /* If the range starts beyond the final printable, it doesn't have any
20109          * in it */
20110         if (start > MAX_PRINT_A) {
20111             break;
20112         }
20113
20114         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
20115          * all but two, the range must start and end no later than 2 from
20116          * either end */
20117         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
20118             if (end > MAX_PRINT_A) {
20119                 end = MAX_PRINT_A;
20120             }
20121             if (start < ' ') {
20122                 start = ' ';
20123             }
20124             if (end - start >= MAX_PRINT_A - ' ' - 2) {
20125                 allow_literals = FALSE;
20126             }
20127             break;
20128         }
20129     }
20130     invlist_iterfinish(invlist);
20131
20132     /* Here we have figured things out.  Output each range */
20133     invlist_iterinit(invlist);
20134     while (invlist_iternext(invlist, &start, &end)) {
20135         if (start >= NUM_ANYOF_CODE_POINTS) {
20136             break;
20137         }
20138         put_range(sv, start, end, allow_literals);
20139     }
20140     invlist_iterfinish(invlist);
20141
20142     return;
20143 }
20144
20145 STATIC SV*
20146 S_put_charclass_bitmap_innards_common(pTHX_
20147         SV* invlist,            /* The bitmap */
20148         SV* posixes,            /* Under /l, things like [:word:], \S */
20149         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
20150         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
20151         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
20152         const bool invert       /* Is the result to be inverted? */
20153 )
20154 {
20155     /* Create and return an SV containing a displayable version of the bitmap
20156      * and associated information determined by the input parameters.  If the
20157      * output would have been only the inversion indicator '^', NULL is instead
20158      * returned. */
20159
20160     SV * output;
20161
20162     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
20163
20164     if (invert) {
20165         output = newSVpvs("^");
20166     }
20167     else {
20168         output = newSVpvs("");
20169     }
20170
20171     /* First, the code points in the bitmap that are unconditionally there */
20172     put_charclass_bitmap_innards_invlist(output, invlist);
20173
20174     /* Traditionally, these have been placed after the main code points */
20175     if (posixes) {
20176         sv_catsv(output, posixes);
20177     }
20178
20179     if (only_utf8 && _invlist_len(only_utf8)) {
20180         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
20181         put_charclass_bitmap_innards_invlist(output, only_utf8);
20182     }
20183
20184     if (not_utf8 && _invlist_len(not_utf8)) {
20185         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
20186         put_charclass_bitmap_innards_invlist(output, not_utf8);
20187     }
20188
20189     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
20190         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
20191         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
20192
20193         /* This is the only list in this routine that can legally contain code
20194          * points outside the bitmap range.  The call just above to
20195          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
20196          * output them here.  There's about a half-dozen possible, and none in
20197          * contiguous ranges longer than 2 */
20198         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20199             UV start, end;
20200             SV* above_bitmap = NULL;
20201
20202             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
20203
20204             invlist_iterinit(above_bitmap);
20205             while (invlist_iternext(above_bitmap, &start, &end)) {
20206                 UV i;
20207
20208                 for (i = start; i <= end; i++) {
20209                     put_code_point(output, i);
20210                 }
20211             }
20212             invlist_iterfinish(above_bitmap);
20213             SvREFCNT_dec_NN(above_bitmap);
20214         }
20215     }
20216
20217     if (invert && SvCUR(output) == 1) {
20218         return NULL;
20219     }
20220
20221     return output;
20222 }
20223
20224 STATIC bool
20225 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
20226                                      char *bitmap,
20227                                      SV *nonbitmap_invlist,
20228                                      SV *only_utf8_locale_invlist,
20229                                      const regnode * const node,
20230                                      const bool force_as_is_display)
20231 {
20232     /* Appends to 'sv' a displayable version of the innards of the bracketed
20233      * character class defined by the other arguments:
20234      *  'bitmap' points to the bitmap.
20235      *  'nonbitmap_invlist' is an inversion list of the code points that are in
20236      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
20237      *      none.  The reasons for this could be that they require some
20238      *      condition such as the target string being or not being in UTF-8
20239      *      (under /d), or because they came from a user-defined property that
20240      *      was not resolved at the time of the regex compilation (under /u)
20241      *  'only_utf8_locale_invlist' is an inversion list of the code points that
20242      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
20243      *  'node' is the regex pattern node.  It is needed only when the above two
20244      *      parameters are not null, and is passed so that this routine can
20245      *      tease apart the various reasons for them.
20246      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
20247      *      to invert things to see if that leads to a cleaner display.  If
20248      *      FALSE, this routine is free to use its judgment about doing this.
20249      *
20250      * It returns TRUE if there was actually something output.  (It may be that
20251      * the bitmap, etc is empty.)
20252      *
20253      * When called for outputting the bitmap of a non-ANYOF node, just pass the
20254      * bitmap, with the succeeding parameters set to NULL, and the final one to
20255      * FALSE.
20256      */
20257
20258     /* In general, it tries to display the 'cleanest' representation of the
20259      * innards, choosing whether to display them inverted or not, regardless of
20260      * whether the class itself is to be inverted.  However,  there are some
20261      * cases where it can't try inverting, as what actually matches isn't known
20262      * until runtime, and hence the inversion isn't either. */
20263     bool inverting_allowed = ! force_as_is_display;
20264
20265     int i;
20266     STRLEN orig_sv_cur = SvCUR(sv);
20267
20268     SV* invlist;            /* Inversion list we accumulate of code points that
20269                                are unconditionally matched */
20270     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
20271                                UTF-8 */
20272     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
20273                              */
20274     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
20275     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
20276                                        is UTF-8 */
20277
20278     SV* as_is_display;      /* The output string when we take the inputs
20279                                literally */
20280     SV* inverted_display;   /* The output string when we invert the inputs */
20281
20282     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
20283
20284     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
20285                                                    to match? */
20286     /* We are biased in favor of displaying things without them being inverted,
20287      * as that is generally easier to understand */
20288     const int bias = 5;
20289
20290     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
20291
20292     /* Start off with whatever code points are passed in.  (We clone, so we
20293      * don't change the caller's list) */
20294     if (nonbitmap_invlist) {
20295         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
20296         invlist = invlist_clone(nonbitmap_invlist);
20297     }
20298     else {  /* Worst case size is every other code point is matched */
20299         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
20300     }
20301
20302     if (flags) {
20303         if (OP(node) == ANYOFD) {
20304
20305             /* This flag indicates that the code points below 0x100 in the
20306              * nonbitmap list are precisely the ones that match only when the
20307              * target is UTF-8 (they should all be non-ASCII). */
20308             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
20309             {
20310                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
20311                 _invlist_subtract(invlist, only_utf8, &invlist);
20312             }
20313
20314             /* And this flag for matching all non-ASCII 0xFF and below */
20315             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
20316             {
20317                 not_utf8 = invlist_clone(PL_UpperLatin1);
20318             }
20319         }
20320         else if (OP(node) == ANYOFL) {
20321
20322             /* If either of these flags are set, what matches isn't
20323              * determinable except during execution, so don't know enough here
20324              * to invert */
20325             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
20326                 inverting_allowed = FALSE;
20327             }
20328
20329             /* What the posix classes match also varies at runtime, so these
20330              * will be output symbolically. */
20331             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
20332                 int i;
20333
20334                 posixes = newSVpvs("");
20335                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
20336                     if (ANYOF_POSIXL_TEST(node,i)) {
20337                         sv_catpv(posixes, anyofs[i]);
20338                     }
20339                 }
20340             }
20341         }
20342     }
20343
20344     /* Accumulate the bit map into the unconditional match list */
20345     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
20346         if (BITMAP_TEST(bitmap, i)) {
20347             int start = i++;
20348             for (; i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i); i++) {
20349                 /* empty */
20350             }
20351             invlist = _add_range_to_invlist(invlist, start, i-1);
20352         }
20353     }
20354
20355     /* Make sure that the conditional match lists don't have anything in them
20356      * that match unconditionally; otherwise the output is quite confusing.
20357      * This could happen if the code that populates these misses some
20358      * duplication. */
20359     if (only_utf8) {
20360         _invlist_subtract(only_utf8, invlist, &only_utf8);
20361     }
20362     if (not_utf8) {
20363         _invlist_subtract(not_utf8, invlist, &not_utf8);
20364     }
20365
20366     if (only_utf8_locale_invlist) {
20367
20368         /* Since this list is passed in, we have to make a copy before
20369          * modifying it */
20370         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
20371
20372         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
20373
20374         /* And, it can get really weird for us to try outputting an inverted
20375          * form of this list when it has things above the bitmap, so don't even
20376          * try */
20377         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20378             inverting_allowed = FALSE;
20379         }
20380     }
20381
20382     /* Calculate what the output would be if we take the input as-is */
20383     as_is_display = put_charclass_bitmap_innards_common(invlist,
20384                                                     posixes,
20385                                                     only_utf8,
20386                                                     not_utf8,
20387                                                     only_utf8_locale,
20388                                                     invert);
20389
20390     /* If have to take the output as-is, just do that */
20391     if (! inverting_allowed) {
20392         if (as_is_display) {
20393             sv_catsv(sv, as_is_display);
20394             SvREFCNT_dec_NN(as_is_display);
20395         }
20396     }
20397     else { /* But otherwise, create the output again on the inverted input, and
20398               use whichever version is shorter */
20399
20400         int inverted_bias, as_is_bias;
20401
20402         /* We will apply our bias to whichever of the the results doesn't have
20403          * the '^' */
20404         if (invert) {
20405             invert = FALSE;
20406             as_is_bias = bias;
20407             inverted_bias = 0;
20408         }
20409         else {
20410             invert = TRUE;
20411             as_is_bias = 0;
20412             inverted_bias = bias;
20413         }
20414
20415         /* Now invert each of the lists that contribute to the output,
20416          * excluding from the result things outside the possible range */
20417
20418         /* For the unconditional inversion list, we have to add in all the
20419          * conditional code points, so that when inverted, they will be gone
20420          * from it */
20421         _invlist_union(only_utf8, invlist, &invlist);
20422         _invlist_union(not_utf8, invlist, &invlist);
20423         _invlist_union(only_utf8_locale, invlist, &invlist);
20424         _invlist_invert(invlist);
20425         _invlist_intersection(invlist, PL_InBitmap, &invlist);
20426
20427         if (only_utf8) {
20428             _invlist_invert(only_utf8);
20429             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
20430         }
20431         else if (not_utf8) {
20432
20433             /* If a code point matches iff the target string is not in UTF-8,
20434              * then complementing the result has it not match iff not in UTF-8,
20435              * which is the same thing as matching iff it is UTF-8. */
20436             only_utf8 = not_utf8;
20437             not_utf8 = NULL;
20438         }
20439
20440         if (only_utf8_locale) {
20441             _invlist_invert(only_utf8_locale);
20442             _invlist_intersection(only_utf8_locale,
20443                                   PL_InBitmap,
20444                                   &only_utf8_locale);
20445         }
20446
20447         inverted_display = put_charclass_bitmap_innards_common(
20448                                             invlist,
20449                                             posixes,
20450                                             only_utf8,
20451                                             not_utf8,
20452                                             only_utf8_locale, invert);
20453
20454         /* Use the shortest representation, taking into account our bias
20455          * against showing it inverted */
20456         if (   inverted_display
20457             && (   ! as_is_display
20458                 || (  SvCUR(inverted_display) + inverted_bias
20459                     < SvCUR(as_is_display)    + as_is_bias)))
20460         {
20461             sv_catsv(sv, inverted_display);
20462         }
20463         else if (as_is_display) {
20464             sv_catsv(sv, as_is_display);
20465         }
20466
20467         SvREFCNT_dec(as_is_display);
20468         SvREFCNT_dec(inverted_display);
20469     }
20470
20471     SvREFCNT_dec_NN(invlist);
20472     SvREFCNT_dec(only_utf8);
20473     SvREFCNT_dec(not_utf8);
20474     SvREFCNT_dec(posixes);
20475     SvREFCNT_dec(only_utf8_locale);
20476
20477     return SvCUR(sv) > orig_sv_cur;
20478 }
20479
20480 #define CLEAR_OPTSTART                                                       \
20481     if (optstart) STMT_START {                                               \
20482         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
20483                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
20484         optstart=NULL;                                                       \
20485     } STMT_END
20486
20487 #define DUMPUNTIL(b,e)                                                       \
20488                     CLEAR_OPTSTART;                                          \
20489                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
20490
20491 STATIC const regnode *
20492 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
20493             const regnode *last, const regnode *plast,
20494             SV* sv, I32 indent, U32 depth)
20495 {
20496     U8 op = PSEUDO;     /* Arbitrary non-END op. */
20497     const regnode *next;
20498     const regnode *optstart= NULL;
20499
20500     RXi_GET_DECL(r,ri);
20501     GET_RE_DEBUG_FLAGS_DECL;
20502
20503     PERL_ARGS_ASSERT_DUMPUNTIL;
20504
20505 #ifdef DEBUG_DUMPUNTIL
20506     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
20507         last ? last-start : 0,plast ? plast-start : 0);
20508 #endif
20509
20510     if (plast && plast < last)
20511         last= plast;
20512
20513     while (PL_regkind[op] != END && (!last || node < last)) {
20514         assert(node);
20515         /* While that wasn't END last time... */
20516         NODE_ALIGN(node);
20517         op = OP(node);
20518         if (op == CLOSE || op == WHILEM)
20519             indent--;
20520         next = regnext((regnode *)node);
20521
20522         /* Where, what. */
20523         if (OP(node) == OPTIMIZED) {
20524             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
20525                 optstart = node;
20526             else
20527                 goto after_print;
20528         } else
20529             CLEAR_OPTSTART;
20530
20531         regprop(r, sv, node, NULL, NULL);
20532         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
20533                       (int)(2*indent + 1), "", SvPVX_const(sv));
20534
20535         if (OP(node) != OPTIMIZED) {
20536             if (next == NULL)           /* Next ptr. */
20537                 Perl_re_printf( aTHX_  " (0)");
20538             else if (PL_regkind[(U8)op] == BRANCH
20539                      && PL_regkind[OP(next)] != BRANCH )
20540                 Perl_re_printf( aTHX_  " (FAIL)");
20541             else
20542                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
20543             Perl_re_printf( aTHX_ "\n");
20544         }
20545
20546       after_print:
20547         if (PL_regkind[(U8)op] == BRANCHJ) {
20548             assert(next);
20549             {
20550                 const regnode *nnode = (OP(next) == LONGJMP
20551                                        ? regnext((regnode *)next)
20552                                        : next);
20553                 if (last && nnode > last)
20554                     nnode = last;
20555                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
20556             }
20557         }
20558         else if (PL_regkind[(U8)op] == BRANCH) {
20559             assert(next);
20560             DUMPUNTIL(NEXTOPER(node), next);
20561         }
20562         else if ( PL_regkind[(U8)op]  == TRIE ) {
20563             const regnode *this_trie = node;
20564             const char op = OP(node);
20565             const U32 n = ARG(node);
20566             const reg_ac_data * const ac = op>=AHOCORASICK ?
20567                (reg_ac_data *)ri->data->data[n] :
20568                NULL;
20569             const reg_trie_data * const trie =
20570                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
20571 #ifdef DEBUGGING
20572             AV *const trie_words
20573                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
20574 #endif
20575             const regnode *nextbranch= NULL;
20576             I32 word_idx;
20577             SvPVCLEAR(sv);
20578             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
20579                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
20580
20581                 Perl_re_indentf( aTHX_  "%s ",
20582                     indent+3,
20583                     elem_ptr
20584                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
20585                                 SvCUR(*elem_ptr), 60,
20586                                 PL_colors[0], PL_colors[1],
20587                                 (SvUTF8(*elem_ptr)
20588                                  ? PERL_PV_ESCAPE_UNI
20589                                  : 0)
20590                                 | PERL_PV_PRETTY_ELLIPSES
20591                                 | PERL_PV_PRETTY_LTGT
20592                             )
20593                     : "???"
20594                 );
20595                 if (trie->jump) {
20596                     U16 dist= trie->jump[word_idx+1];
20597                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
20598                                (UV)((dist ? this_trie + dist : next) - start));
20599                     if (dist) {
20600                         if (!nextbranch)
20601                             nextbranch= this_trie + trie->jump[0];
20602                         DUMPUNTIL(this_trie + dist, nextbranch);
20603                     }
20604                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
20605                         nextbranch= regnext((regnode *)nextbranch);
20606                 } else {
20607                     Perl_re_printf( aTHX_  "\n");
20608                 }
20609             }
20610             if (last && next > last)
20611                 node= last;
20612             else
20613                 node= next;
20614         }
20615         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
20616             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
20617                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
20618         }
20619         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
20620             assert(next);
20621             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
20622         }
20623         else if ( op == PLUS || op == STAR) {
20624             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
20625         }
20626         else if (PL_regkind[(U8)op] == ANYOF) {
20627             /* arglen 1 + class block */
20628             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
20629                           ? ANYOF_POSIXL_SKIP
20630                           : ANYOF_SKIP);
20631             node = NEXTOPER(node);
20632         }
20633         else if (PL_regkind[(U8)op] == EXACT) {
20634             /* Literal string, where present. */
20635             node += NODE_SZ_STR(node) - 1;
20636             node = NEXTOPER(node);
20637         }
20638         else {
20639             node = NEXTOPER(node);
20640             node += regarglen[(U8)op];
20641         }
20642         if (op == CURLYX || op == OPEN)
20643             indent++;
20644     }
20645     CLEAR_OPTSTART;
20646 #ifdef DEBUG_DUMPUNTIL
20647     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
20648 #endif
20649     return node;
20650 }
20651
20652 #endif  /* DEBUGGING */
20653
20654 /*
20655  * ex: set ts=8 sts=4 sw=4 et:
20656  */