This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Spelling correction.
[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
114     struct scan_frame *this_prev_frame; /* this previous frame */
115     struct scan_frame *prev_frame;      /* previous frame */
116     struct scan_frame *next_frame;      /* next frame */
117 } scan_frame;
118
119 /* Certain characters are output as a sequence with the first being a
120  * backslash. */
121 #define isBACKSLASHED_PUNCT(c)  strchr("-[]\\^", c)
122
123
124 struct RExC_state_t {
125     U32         flags;                  /* RXf_* are we folding, multilining? */
126     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
127     char        *precomp;               /* uncompiled string. */
128     char        *precomp_end;           /* pointer to end of uncompiled string. */
129     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
130     regexp      *rx;                    /* perl core regexp structure */
131     regexp_internal     *rxi;           /* internal data for regexp object
132                                            pprivate field */
133     char        *start;                 /* Start of input for compile */
134     char        *end;                   /* End of input for compile */
135     char        *parse;                 /* Input-scan pointer. */
136     char        *adjusted_start;        /* 'start', adjusted.  See code use */
137     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
138     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
139     regnode     *emit_start;            /* Start of emitted-code area */
140     regnode     *emit_bound;            /* First regnode outside of the
141                                            allocated space */
142     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
143                                            implies compiling, so don't emit */
144     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
145                                            large enough for the largest
146                                            non-EXACTish node, so can use it as
147                                            scratch in pass1 */
148     I32         naughty;                /* How bad is this pattern? */
149     I32         sawback;                /* Did we see \1, ...? */
150     U32         seen;
151     SSize_t     size;                   /* Code size. */
152     I32         npar;                   /* Capture buffer count, (OPEN) plus
153                                            one. ("par" 0 is the whole
154                                            pattern)*/
155     I32         nestroot;               /* root parens we are in - used by
156                                            accept */
157     I32         extralen;
158     I32         seen_zerolen;
159     regnode     **open_parens;          /* pointers to open parens */
160     regnode     **close_parens;         /* pointers to close parens */
161     regnode     *end_op;                /* END node in program */
162     I32         utf8;           /* whether the pattern is utf8 or not */
163     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
164                                 /* XXX use this for future optimisation of case
165                                  * where pattern must be upgraded to utf8. */
166     I32         uni_semantics;  /* If a d charset modifier should use unicode
167                                    rules, even if the pattern is not in
168                                    utf8 */
169     HV          *paren_names;           /* Paren names */
170
171     regnode     **recurse;              /* Recurse regops */
172     I32                recurse_count;                /* Number of recurse regops we have generated */
173     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
174                                            through */
175     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
176     I32         in_lookbehind;
177     I32         contains_locale;
178     I32         override_recoding;
179 #ifdef EBCDIC
180     I32         recode_x_to_native;
181 #endif
182     I32         in_multi_char_class;
183     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
184                                             within pattern */
185     int         code_index;             /* next code_blocks[] slot */
186     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
187     scan_frame *frame_head;
188     scan_frame *frame_last;
189     U32         frame_count;
190     AV         *warn_text;
191 #ifdef ADD_TO_REGEXEC
192     char        *starttry;              /* -Dr: where regtry was called. */
193 #define RExC_starttry   (pRExC_state->starttry)
194 #endif
195     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
196 #ifdef DEBUGGING
197     const char  *lastparse;
198     I32         lastnum;
199     AV          *paren_name_list;       /* idx -> name */
200     U32         study_chunk_recursed_count;
201     SV          *mysv1;
202     SV          *mysv2;
203 #define RExC_lastparse  (pRExC_state->lastparse)
204 #define RExC_lastnum    (pRExC_state->lastnum)
205 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
206 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
207 #define RExC_mysv       (pRExC_state->mysv1)
208 #define RExC_mysv1      (pRExC_state->mysv1)
209 #define RExC_mysv2      (pRExC_state->mysv2)
210
211 #endif
212     bool        seen_unfolded_sharp_s;
213     bool        strict;
214     bool        study_started;
215     bool        in_script_run;
216 };
217
218 #define RExC_flags      (pRExC_state->flags)
219 #define RExC_pm_flags   (pRExC_state->pm_flags)
220 #define RExC_precomp    (pRExC_state->precomp)
221 #define RExC_precomp_adj (pRExC_state->precomp_adj)
222 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
223 #define RExC_precomp_end (pRExC_state->precomp_end)
224 #define RExC_rx_sv      (pRExC_state->rx_sv)
225 #define RExC_rx         (pRExC_state->rx)
226 #define RExC_rxi        (pRExC_state->rxi)
227 #define RExC_start      (pRExC_state->start)
228 #define RExC_end        (pRExC_state->end)
229 #define RExC_parse      (pRExC_state->parse)
230 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
231
232 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
233  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
234  * something forces the pattern into using /ui rules, the sharp s should be
235  * folded into the sequence 'ss', which takes up more space than previously
236  * calculated.  This means that the sizing pass needs to be restarted.  (The
237  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
238  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
239  * so there is no need to resize [perl #125990]. */
240 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
241
242 #ifdef RE_TRACK_PATTERN_OFFSETS
243 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
244                                                          others */
245 #endif
246 #define RExC_emit       (pRExC_state->emit)
247 #define RExC_emit_dummy (pRExC_state->emit_dummy)
248 #define RExC_emit_start (pRExC_state->emit_start)
249 #define RExC_emit_bound (pRExC_state->emit_bound)
250 #define RExC_sawback    (pRExC_state->sawback)
251 #define RExC_seen       (pRExC_state->seen)
252 #define RExC_size       (pRExC_state->size)
253 #define RExC_maxlen        (pRExC_state->maxlen)
254 #define RExC_npar       (pRExC_state->npar)
255 #define RExC_nestroot   (pRExC_state->nestroot)
256 #define RExC_extralen   (pRExC_state->extralen)
257 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
258 #define RExC_utf8       (pRExC_state->utf8)
259 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
260 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
261 #define RExC_open_parens        (pRExC_state->open_parens)
262 #define RExC_close_parens       (pRExC_state->close_parens)
263 #define RExC_end_op     (pRExC_state->end_op)
264 #define RExC_paren_names        (pRExC_state->paren_names)
265 #define RExC_recurse    (pRExC_state->recurse)
266 #define RExC_recurse_count      (pRExC_state->recurse_count)
267 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
268 #define RExC_study_chunk_recursed_bytes  \
269                                    (pRExC_state->study_chunk_recursed_bytes)
270 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
271 #define RExC_contains_locale    (pRExC_state->contains_locale)
272 #ifdef EBCDIC
273 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
274 #endif
275 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
276 #define RExC_frame_head (pRExC_state->frame_head)
277 #define RExC_frame_last (pRExC_state->frame_last)
278 #define RExC_frame_count (pRExC_state->frame_count)
279 #define RExC_strict (pRExC_state->strict)
280 #define RExC_study_started      (pRExC_state->study_started)
281 #define RExC_warn_text (pRExC_state->warn_text)
282 #define RExC_in_script_run      (pRExC_state->in_script_run)
283
284 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
285  * a flag to disable back-off on the fixed/floating substrings - if it's
286  * a high complexity pattern we assume the benefit of avoiding a full match
287  * is worth the cost of checking for the substrings even if they rarely help.
288  */
289 #define RExC_naughty    (pRExC_state->naughty)
290 #define TOO_NAUGHTY (10)
291 #define MARK_NAUGHTY(add) \
292     if (RExC_naughty < TOO_NAUGHTY) \
293         RExC_naughty += (add)
294 #define MARK_NAUGHTY_EXP(exp, add) \
295     if (RExC_naughty < TOO_NAUGHTY) \
296         RExC_naughty += RExC_naughty / (exp) + (add)
297
298 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
299 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
300         ((*s) == '{' && regcurly(s)))
301
302 /*
303  * Flags to be passed up and down.
304  */
305 #define WORST           0       /* Worst case. */
306 #define HASWIDTH        0x01    /* Known to match non-null strings. */
307
308 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
309  * character.  (There needs to be a case: in the switch statement in regexec.c
310  * for any node marked SIMPLE.)  Note that this is not the same thing as
311  * REGNODE_SIMPLE */
312 #define SIMPLE          0x02
313 #define SPSTART         0x04    /* Starts with * or + */
314 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
315 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
316 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
317 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
318                                    calcuate sizes as UTF-8 */
319
320 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
321
322 /* whether trie related optimizations are enabled */
323 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
324 #define TRIE_STUDY_OPT
325 #define FULL_TRIE_STUDY
326 #define TRIE_STCLASS
327 #endif
328
329
330
331 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
332 #define PBITVAL(paren) (1 << ((paren) & 7))
333 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
334 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
335 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
336
337 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
338                                      if (!UTF) {                           \
339                                          assert(PASS1);                    \
340                                          *flagp = RESTART_PASS1|NEED_UTF8; \
341                                          return NULL;                      \
342                                      }                                     \
343                              } STMT_END
344
345 /* Change from /d into /u rules, and restart the parse if we've already seen
346  * something whose size would increase as a result, by setting *flagp and
347  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
348  * we've changed to /u during the parse.  */
349 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
350     STMT_START {                                                            \
351             if (DEPENDS_SEMANTICS) {                                        \
352                 assert(PASS1);                                              \
353                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
354                 RExC_uni_semantics = 1;                                     \
355                 if (RExC_seen_unfolded_sharp_s) {                           \
356                     *flagp |= RESTART_PASS1;                                \
357                     return restart_retval;                                  \
358                 }                                                           \
359             }                                                               \
360     } STMT_END
361
362 /* Executes a return statement with the value 'X', if 'flags' contains any of
363  * 'RESTART_PASS1', 'NEED_UTF8', or 'extra'.  If so, *flagp is set to those
364  * flags */
365 #define RETURN_X_ON_RESTART_OR_FLAGS(X, flags, flagp, extra)                \
366     STMT_START {                                                            \
367             if ((flags) & (RESTART_PASS1|NEED_UTF8|(extra))) {              \
368                 *(flagp) = (flags) & (RESTART_PASS1|NEED_UTF8|(extra));     \
369                 return X;                                                   \
370             }                                                               \
371     } STMT_END
372
373 #define RETURN_NULL_ON_RESTART_OR_FLAGS(flags,flagp,extra)                  \
374                     RETURN_X_ON_RESTART_OR_FLAGS(NULL,flags,flagp,extra)
375
376 #define RETURN_X_ON_RESTART(X, flags,flagp)                                 \
377                         RETURN_X_ON_RESTART_OR_FLAGS( X, flags, flagp, 0)
378
379
380 #define RETURN_NULL_ON_RESTART_FLAGP_OR_FLAGS(flagp,extra)                  \
381             if (*(flagp) & (RESTART_PASS1|(extra))) return NULL
382
383 #define MUST_RESTART(flags) ((flags) & (RESTART_PASS1))
384
385 #define RETURN_NULL_ON_RESTART(flags,flagp)                                 \
386                                     RETURN_X_ON_RESTART(NULL, flags,flagp)
387 #define RETURN_NULL_ON_RESTART_FLAGP(flagp)                                 \
388                             RETURN_NULL_ON_RESTART_FLAGP_OR_FLAGS(flagp,0)
389
390 /* This converts the named class defined in regcomp.h to its equivalent class
391  * number defined in handy.h. */
392 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
393 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
394
395 #define _invlist_union_complement_2nd(a, b, output) \
396                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
397 #define _invlist_intersection_complement_2nd(a, b, output) \
398                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
399
400 /* About scan_data_t.
401
402   During optimisation we recurse through the regexp program performing
403   various inplace (keyhole style) optimisations. In addition study_chunk
404   and scan_commit populate this data structure with information about
405   what strings MUST appear in the pattern. We look for the longest
406   string that must appear at a fixed location, and we look for the
407   longest string that may appear at a floating location. So for instance
408   in the pattern:
409
410     /FOO[xX]A.*B[xX]BAR/
411
412   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
413   strings (because they follow a .* construct). study_chunk will identify
414   both FOO and BAR as being the longest fixed and floating strings respectively.
415
416   The strings can be composites, for instance
417
418      /(f)(o)(o)/
419
420   will result in a composite fixed substring 'foo'.
421
422   For each string some basic information is maintained:
423
424   - min_offset
425     This is the position the string must appear at, or not before.
426     It also implicitly (when combined with minlenp) tells us how many
427     characters must match before the string we are searching for.
428     Likewise when combined with minlenp and the length of the string it
429     tells us how many characters must appear after the string we have
430     found.
431
432   - max_offset
433     Only used for floating strings. This is the rightmost point that
434     the string can appear at. If set to SSize_t_MAX it indicates that the
435     string can occur infinitely far to the right.
436     For fixed strings, it is equal to min_offset.
437
438   - minlenp
439     A pointer to the minimum number of characters of the pattern that the
440     string was found inside. This is important as in the case of positive
441     lookahead or positive lookbehind we can have multiple patterns
442     involved. Consider
443
444     /(?=FOO).*F/
445
446     The minimum length of the pattern overall is 3, the minimum length
447     of the lookahead part is 3, but the minimum length of the part that
448     will actually match is 1. So 'FOO's minimum length is 3, but the
449     minimum length for the F is 1. This is important as the minimum length
450     is used to determine offsets in front of and behind the string being
451     looked for.  Since strings can be composites this is the length of the
452     pattern at the time it was committed with a scan_commit. Note that
453     the length is calculated by study_chunk, so that the minimum lengths
454     are not known until the full pattern has been compiled, thus the
455     pointer to the value.
456
457   - lookbehind
458
459     In the case of lookbehind the string being searched for can be
460     offset past the start point of the final matching string.
461     If this value was just blithely removed from the min_offset it would
462     invalidate some of the calculations for how many chars must match
463     before or after (as they are derived from min_offset and minlen and
464     the length of the string being searched for).
465     When the final pattern is compiled and the data is moved from the
466     scan_data_t structure into the regexp structure the information
467     about lookbehind is factored in, with the information that would
468     have been lost precalculated in the end_shift field for the
469     associated string.
470
471   The fields pos_min and pos_delta are used to store the minimum offset
472   and the delta to the maximum offset at the current point in the pattern.
473
474 */
475
476 struct scan_data_substrs {
477     SV      *str;       /* longest substring found in pattern */
478     SSize_t min_offset; /* earliest point in string it can appear */
479     SSize_t max_offset; /* latest point in string it can appear */
480     SSize_t *minlenp;   /* pointer to the minlen relevant to the string */
481     SSize_t lookbehind; /* is the pos of the string modified by LB */
482     I32 flags;          /* per substring SF_* and SCF_* flags */
483 };
484
485 typedef struct scan_data_t {
486     /*I32 len_min;      unused */
487     /*I32 len_delta;    unused */
488     SSize_t pos_min;
489     SSize_t pos_delta;
490     SV *last_found;
491     SSize_t last_end;       /* min value, <0 unless valid. */
492     SSize_t last_start_min;
493     SSize_t last_start_max;
494     U8      cur_is_floating; /* whether the last_* values should be set as
495                               * the next fixed (0) or floating (1)
496                               * substring */
497
498     /* [0] is longest fixed substring so far, [1] is longest float so far */
499     struct scan_data_substrs  substrs[2];
500
501     I32 flags;             /* common SF_* and SCF_* flags */
502     I32 whilem_c;
503     SSize_t *last_closep;
504     regnode_ssc *start_class;
505 } scan_data_t;
506
507 /*
508  * Forward declarations for pregcomp()'s friends.
509  */
510
511 static const scan_data_t zero_scan_data = {
512     0, 0, NULL, 0, 0, 0, 0,
513     {
514         { NULL, 0, 0, 0, 0, 0 },
515         { NULL, 0, 0, 0, 0, 0 },
516     },
517     0, 0, NULL, NULL
518 };
519
520 /* study flags */
521
522 #define SF_BEFORE_SEOL          0x0001
523 #define SF_BEFORE_MEOL          0x0002
524 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
525
526 #define SF_IS_INF               0x0040
527 #define SF_HAS_PAR              0x0080
528 #define SF_IN_PAR               0x0100
529 #define SF_HAS_EVAL             0x0200
530
531
532 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
533  * longest substring in the pattern. When it is not set the optimiser keeps
534  * track of position, but does not keep track of the actual strings seen,
535  *
536  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
537  * /foo/i will not.
538  *
539  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
540  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
541  * turned off because of the alternation (BRANCH). */
542 #define SCF_DO_SUBSTR           0x0400
543
544 #define SCF_DO_STCLASS_AND      0x0800
545 #define SCF_DO_STCLASS_OR       0x1000
546 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
547 #define SCF_WHILEM_VISITED_POS  0x2000
548
549 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
550 #define SCF_SEEN_ACCEPT         0x8000
551 #define SCF_TRIE_DOING_RESTUDY 0x10000
552 #define SCF_IN_DEFINE          0x20000
553
554
555
556
557 #define UTF cBOOL(RExC_utf8)
558
559 /* The enums for all these are ordered so things work out correctly */
560 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
561 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
562                                                      == REGEX_DEPENDS_CHARSET)
563 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
564 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
565                                                      >= REGEX_UNICODE_CHARSET)
566 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
567                                             == REGEX_ASCII_RESTRICTED_CHARSET)
568 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
569                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
570 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
571                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
572
573 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
574
575 /* For programs that want to be strictly Unicode compatible by dying if any
576  * attempt is made to match a non-Unicode code point against a Unicode
577  * property.  */
578 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
579
580 #define OOB_NAMEDCLASS          -1
581
582 /* There is no code point that is out-of-bounds, so this is problematic.  But
583  * its only current use is to initialize a variable that is always set before
584  * looked at. */
585 #define OOB_UNICODE             0xDEADBEEF
586
587 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
588
589
590 /* length of regex to show in messages that don't mark a position within */
591 #define RegexLengthToShowInErrorMessages 127
592
593 /*
594  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
595  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
596  * op/pragma/warn/regcomp.
597  */
598 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
599 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
600
601 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
602                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
603
604 /* The code in this file in places uses one level of recursion with parsing
605  * rebased to an alternate string constructed by us in memory.  This can take
606  * the form of something that is completely different from the input, or
607  * something that uses the input as part of the alternate.  In the first case,
608  * there should be no possibility of an error, as we are in complete control of
609  * the alternate string.  But in the second case we don't control the input
610  * portion, so there may be errors in that.  Here's an example:
611  *      /[abc\x{DF}def]/ui
612  * is handled specially because \x{df} folds to a sequence of more than one
613  * character, 'ss'.  What is done is to create and parse an alternate string,
614  * which looks like this:
615  *      /(?:\x{DF}|[abc\x{DF}def])/ui
616  * where it uses the input unchanged in the middle of something it constructs,
617  * which is a branch for the DF outside the character class, and clustering
618  * parens around the whole thing. (It knows enough to skip the DF inside the
619  * class while in this substitute parse.) 'abc' and 'def' may have errors that
620  * need to be reported.  The general situation looks like this:
621  *
622  *              sI                       tI               xI       eI
623  * Input:       ----------------------------------------------------
624  * Constructed:         ---------------------------------------------------
625  *                      sC               tC               xC       eC     EC
626  *
627  * The input string sI..eI is the input pattern.  The string sC..EC is the
628  * constructed substitute parse string.  The portions sC..tC and eC..EC are
629  * constructed by us.  The portion tC..eC is an exact duplicate of the input
630  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
631  * while parsing, we find an error at xC.  We want to display a message showing
632  * the real input string.  Thus we need to find the point xI in it which
633  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
634  * been constructed by us, and so shouldn't have errors.  We get:
635  *
636  *      xI = sI + (tI - sI) + (xC - tC)
637  *
638  * and, the offset into sI is:
639  *
640  *      (xI - sI) = (tI - sI) + (xC - tC)
641  *
642  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
643  * and we save tC as RExC_adjusted_start.
644  *
645  * During normal processing of the input pattern, everything points to that,
646  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
647  */
648
649 #define tI_sI           RExC_precomp_adj
650 #define tC              RExC_adjusted_start
651 #define sC              RExC_precomp
652 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
653 #define xI(xC)          (sC + xI_offset(xC))
654 #define eC              RExC_precomp_end
655
656 #define REPORT_LOCATION_ARGS(xC)                                            \
657     UTF8fARG(UTF,                                                           \
658              (xI(xC) > eC) /* Don't run off end */                          \
659               ? eC - sC   /* Length before the <--HERE */                   \
660               : ( __ASSERT_(xI_offset(xC) >= 0) xI_offset(xC) ),            \
661              sC),         /* The input pattern printed up to the <--HERE */ \
662     UTF8fARG(UTF,                                                           \
663              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
664              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
665
666 /* Used to point after bad bytes for an error message, but avoid skipping
667  * past a nul byte. */
668 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
669
670 /*
671  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
672  * arg. Show regex, up to a maximum length. If it's too long, chop and add
673  * "...".
674  */
675 #define _FAIL(code) STMT_START {                                        \
676     const char *ellipses = "";                                          \
677     IV len = RExC_precomp_end - RExC_precomp;                                   \
678                                                                         \
679     if (!SIZE_ONLY)                                                     \
680         SAVEFREESV(RExC_rx_sv);                                         \
681     if (len > RegexLengthToShowInErrorMessages) {                       \
682         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
683         len = RegexLengthToShowInErrorMessages - 10;                    \
684         ellipses = "...";                                               \
685     }                                                                   \
686     code;                                                               \
687 } STMT_END
688
689 #define FAIL(msg) _FAIL(                            \
690     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
691             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
692
693 #define FAIL2(msg,arg) _FAIL(                       \
694     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
695             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
696
697 /*
698  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
699  */
700 #define Simple_vFAIL(m) STMT_START {                                    \
701     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
702             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
703 } STMT_END
704
705 /*
706  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
707  */
708 #define vFAIL(m) STMT_START {                           \
709     if (!SIZE_ONLY)                                     \
710         SAVEFREESV(RExC_rx_sv);                         \
711     Simple_vFAIL(m);                                    \
712 } STMT_END
713
714 /*
715  * Like Simple_vFAIL(), but accepts two arguments.
716  */
717 #define Simple_vFAIL2(m,a1) STMT_START {                        \
718     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
719                       REPORT_LOCATION_ARGS(RExC_parse));        \
720 } STMT_END
721
722 /*
723  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
724  */
725 #define vFAIL2(m,a1) STMT_START {                       \
726     if (!SIZE_ONLY)                                     \
727         SAVEFREESV(RExC_rx_sv);                         \
728     Simple_vFAIL2(m, a1);                               \
729 } STMT_END
730
731
732 /*
733  * Like Simple_vFAIL(), but accepts three arguments.
734  */
735 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
736     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
737             REPORT_LOCATION_ARGS(RExC_parse));                  \
738 } STMT_END
739
740 /*
741  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
742  */
743 #define vFAIL3(m,a1,a2) STMT_START {                    \
744     if (!SIZE_ONLY)                                     \
745         SAVEFREESV(RExC_rx_sv);                         \
746     Simple_vFAIL3(m, a1, a2);                           \
747 } STMT_END
748
749 /*
750  * Like Simple_vFAIL(), but accepts four arguments.
751  */
752 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
753     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
754             REPORT_LOCATION_ARGS(RExC_parse));                  \
755 } STMT_END
756
757 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
758     if (!SIZE_ONLY)                                     \
759         SAVEFREESV(RExC_rx_sv);                         \
760     Simple_vFAIL4(m, a1, a2, a3);                       \
761 } STMT_END
762
763 /* A specialized version of vFAIL2 that works with UTF8f */
764 #define vFAIL2utf8f(m, a1) STMT_START {             \
765     if (!SIZE_ONLY)                                 \
766         SAVEFREESV(RExC_rx_sv);                     \
767     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
768             REPORT_LOCATION_ARGS(RExC_parse));      \
769 } STMT_END
770
771 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
772     if (!SIZE_ONLY)                                     \
773         SAVEFREESV(RExC_rx_sv);                         \
774     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
775             REPORT_LOCATION_ARGS(RExC_parse));          \
776 } STMT_END
777
778 /* These have asserts in them because of [perl #122671] Many warnings in
779  * regcomp.c can occur twice.  If they get output in pass1 and later in that
780  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
781  * would get output again.  So they should be output in pass2, and these
782  * asserts make sure new warnings follow that paradigm. */
783
784 /* m is not necessarily a "literal string", in this macro */
785 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
786     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
787                                        "%s" REPORT_LOCATION,            \
788                                   m, REPORT_LOCATION_ARGS(loc));        \
789 } STMT_END
790
791 #define ckWARNreg(loc,m) STMT_START {                                   \
792     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
793                                           m REPORT_LOCATION,            \
794                                           REPORT_LOCATION_ARGS(loc));   \
795 } STMT_END
796
797 #define vWARN(loc, m) STMT_START {                                      \
798     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
799                                        m REPORT_LOCATION,               \
800                                        REPORT_LOCATION_ARGS(loc));      \
801 } STMT_END
802
803 #define vWARN_dep(loc, m) STMT_START {                                  \
804     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
805                                        m REPORT_LOCATION,               \
806                                        REPORT_LOCATION_ARGS(loc));      \
807 } STMT_END
808
809 #define ckWARNdep(loc,m) STMT_START {                                   \
810     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
811                                             m REPORT_LOCATION,          \
812                                             REPORT_LOCATION_ARGS(loc)); \
813 } STMT_END
814
815 #define ckWARNregdep(loc,m) STMT_START {                                    \
816     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
817                                                       WARN_REGEXP),         \
818                                              m REPORT_LOCATION,             \
819                                              REPORT_LOCATION_ARGS(loc));    \
820 } STMT_END
821
822 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
823     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
824                                             m REPORT_LOCATION,              \
825                                             a1, REPORT_LOCATION_ARGS(loc)); \
826 } STMT_END
827
828 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
829     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
830                                           m REPORT_LOCATION,                \
831                                           a1, REPORT_LOCATION_ARGS(loc));   \
832 } STMT_END
833
834 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
835     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
836                                        m REPORT_LOCATION,                   \
837                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
838 } STMT_END
839
840 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
841     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
842                                           m REPORT_LOCATION,                \
843                                           a1, a2,                           \
844                                           REPORT_LOCATION_ARGS(loc));       \
845 } STMT_END
846
847 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
848     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
849                                        m REPORT_LOCATION,               \
850                                        a1, a2, a3,                      \
851                                        REPORT_LOCATION_ARGS(loc));      \
852 } STMT_END
853
854 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
855     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
856                                           m REPORT_LOCATION,            \
857                                           a1, a2, a3,                   \
858                                           REPORT_LOCATION_ARGS(loc));   \
859 } STMT_END
860
861 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
862     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
863                                        m REPORT_LOCATION,               \
864                                        a1, a2, a3, a4,                  \
865                                        REPORT_LOCATION_ARGS(loc));      \
866 } STMT_END
867
868 /* Macros for recording node offsets.   20001227 mjd@plover.com
869  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
870  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
871  * Element 0 holds the number n.
872  * Position is 1 indexed.
873  */
874 #ifndef RE_TRACK_PATTERN_OFFSETS
875 #define Set_Node_Offset_To_R(node,byte)
876 #define Set_Node_Offset(node,byte)
877 #define Set_Cur_Node_Offset
878 #define Set_Node_Length_To_R(node,len)
879 #define Set_Node_Length(node,len)
880 #define Set_Node_Cur_Length(node,start)
881 #define Node_Offset(n)
882 #define Node_Length(n)
883 #define Set_Node_Offset_Length(node,offset,len)
884 #define ProgLen(ri) ri->u.proglen
885 #define SetProgLen(ri,x) ri->u.proglen = x
886 #else
887 #define ProgLen(ri) ri->u.offsets[0]
888 #define SetProgLen(ri,x) ri->u.offsets[0] = x
889 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
890     if (! SIZE_ONLY) {                                                  \
891         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
892                     __LINE__, (int)(node), (int)(byte)));               \
893         if((node) < 0) {                                                \
894             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
895                                          (int)(node));                  \
896         } else {                                                        \
897             RExC_offsets[2*(node)-1] = (byte);                          \
898         }                                                               \
899     }                                                                   \
900 } STMT_END
901
902 #define Set_Node_Offset(node,byte) \
903     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
904 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
905
906 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
907     if (! SIZE_ONLY) {                                                  \
908         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
909                 __LINE__, (int)(node), (int)(len)));                    \
910         if((node) < 0) {                                                \
911             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
912                                          (int)(node));                  \
913         } else {                                                        \
914             RExC_offsets[2*(node)] = (len);                             \
915         }                                                               \
916     }                                                                   \
917 } STMT_END
918
919 #define Set_Node_Length(node,len) \
920     Set_Node_Length_To_R((node)-RExC_emit_start, len)
921 #define Set_Node_Cur_Length(node, start)                \
922     Set_Node_Length(node, RExC_parse - start)
923
924 /* Get offsets and lengths */
925 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
926 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
927
928 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
929     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
930     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
931 } STMT_END
932 #endif
933
934 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
935 #define EXPERIMENTAL_INPLACESCAN
936 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
937
938 #ifdef DEBUGGING
939 int
940 Perl_re_printf(pTHX_ const char *fmt, ...)
941 {
942     va_list ap;
943     int result;
944     PerlIO *f= Perl_debug_log;
945     PERL_ARGS_ASSERT_RE_PRINTF;
946     va_start(ap, fmt);
947     result = PerlIO_vprintf(f, fmt, ap);
948     va_end(ap);
949     return result;
950 }
951
952 int
953 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
954 {
955     va_list ap;
956     int result;
957     PerlIO *f= Perl_debug_log;
958     PERL_ARGS_ASSERT_RE_INDENTF;
959     va_start(ap, depth);
960     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
961     result = PerlIO_vprintf(f, fmt, ap);
962     va_end(ap);
963     return result;
964 }
965 #endif /* DEBUGGING */
966
967 #define DEBUG_RExC_seen()                                                   \
968         DEBUG_OPTIMISE_MORE_r({                                             \
969             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
970                                                                             \
971             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
972                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
973                                                                             \
974             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
975                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
976                                                                             \
977             if (RExC_seen & REG_GPOS_SEEN)                                  \
978                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
979                                                                             \
980             if (RExC_seen & REG_RECURSE_SEEN)                               \
981                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
982                                                                             \
983             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
984                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
985                                                                             \
986             if (RExC_seen & REG_VERBARG_SEEN)                               \
987                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
988                                                                             \
989             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
990                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
991                                                                             \
992             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
993                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
994                                                                             \
995             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
996                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
997                                                                             \
998             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
999                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
1000                                                                             \
1001             Perl_re_printf( aTHX_ "\n");                                                \
1002         });
1003
1004 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
1005   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
1006
1007
1008 #ifdef DEBUGGING
1009 static void
1010 S_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
1011                                     const char *close_str)
1012 {
1013     if (!flags)
1014         return;
1015
1016     Perl_re_printf( aTHX_  "%s", open_str);
1017     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
1018     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
1019     DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
1020     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
1021     DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
1022     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
1023     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
1024     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
1025     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
1026     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
1027     DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
1028     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
1029     DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
1030     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
1031     DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
1032     Perl_re_printf( aTHX_  "%s", close_str);
1033 }
1034
1035
1036 static void
1037 S_debug_studydata(pTHX_ const char *where, scan_data_t *data,
1038                     U32 depth, int is_inf)
1039 {
1040     GET_RE_DEBUG_FLAGS_DECL;
1041
1042     DEBUG_OPTIMISE_MORE_r({
1043         if (!data)
1044             return;
1045         Perl_re_indentf(aTHX_  "%s: Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
1046             depth,
1047             where,
1048             (IV)data->pos_min,
1049             (IV)data->pos_delta,
1050             (UV)data->flags
1051         );
1052
1053         S_debug_show_study_flags(aTHX_ data->flags," [","]");
1054
1055         Perl_re_printf( aTHX_
1056             " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
1057             (IV)data->whilem_c,
1058             (IV)(data->last_closep ? *((data)->last_closep) : -1),
1059             is_inf ? "INF " : ""
1060         );
1061
1062         if (data->last_found) {
1063             int i;
1064             Perl_re_printf(aTHX_
1065                 "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
1066                     SvPVX_const(data->last_found),
1067                     (IV)data->last_end,
1068                     (IV)data->last_start_min,
1069                     (IV)data->last_start_max
1070             );
1071
1072             for (i = 0; i < 2; i++) {
1073                 Perl_re_printf(aTHX_
1074                     " %s%s: '%s' @ %" IVdf "/%" IVdf,
1075                     data->cur_is_floating == i ? "*" : "",
1076                     i ? "Float" : "Fixed",
1077                     SvPVX_const(data->substrs[i].str),
1078                     (IV)data->substrs[i].min_offset,
1079                     (IV)data->substrs[i].max_offset
1080                 );
1081                 S_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
1082             }
1083         }
1084
1085         Perl_re_printf( aTHX_ "\n");
1086     });
1087 }
1088
1089
1090 static void
1091 S_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
1092                 regnode *scan, U32 depth, U32 flags)
1093 {
1094     GET_RE_DEBUG_FLAGS_DECL;
1095
1096     DEBUG_OPTIMISE_r({
1097         regnode *Next;
1098
1099         if (!scan)
1100             return;
1101         Next = regnext(scan);
1102         regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
1103         Perl_re_indentf( aTHX_   "%s>%3d: %s (%d)",
1104             depth,
1105             str,
1106             REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
1107             Next ? (REG_NODE_NUM(Next)) : 0 );
1108         S_debug_show_study_flags(aTHX_ flags," [ ","]");
1109         Perl_re_printf( aTHX_  "\n");
1110    });
1111 }
1112
1113
1114 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) \
1115                     S_debug_studydata(aTHX_ where, data, depth, is_inf)
1116
1117 #  define DEBUG_PEEP(str, scan, depth, flags)   \
1118                     S_debug_peep(aTHX_ str, pRExC_state, scan, depth, flags)
1119
1120 #else
1121 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) NOOP
1122 #  define DEBUG_PEEP(str, scan, depth, flags)         NOOP
1123 #endif
1124
1125
1126 /* =========================================================
1127  * BEGIN edit_distance stuff.
1128  *
1129  * This calculates how many single character changes of any type are needed to
1130  * transform a string into another one.  It is taken from version 3.1 of
1131  *
1132  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1133  */
1134
1135 /* Our unsorted dictionary linked list.   */
1136 /* Note we use UVs, not chars. */
1137
1138 struct dictionary{
1139   UV key;
1140   UV value;
1141   struct dictionary* next;
1142 };
1143 typedef struct dictionary item;
1144
1145
1146 PERL_STATIC_INLINE item*
1147 push(UV key,item* curr)
1148 {
1149     item* head;
1150     Newx(head, 1, item);
1151     head->key = key;
1152     head->value = 0;
1153     head->next = curr;
1154     return head;
1155 }
1156
1157
1158 PERL_STATIC_INLINE item*
1159 find(item* head, UV key)
1160 {
1161     item* iterator = head;
1162     while (iterator){
1163         if (iterator->key == key){
1164             return iterator;
1165         }
1166         iterator = iterator->next;
1167     }
1168
1169     return NULL;
1170 }
1171
1172 PERL_STATIC_INLINE item*
1173 uniquePush(item* head,UV key)
1174 {
1175     item* iterator = head;
1176
1177     while (iterator){
1178         if (iterator->key == key) {
1179             return head;
1180         }
1181         iterator = iterator->next;
1182     }
1183
1184     return push(key,head);
1185 }
1186
1187 PERL_STATIC_INLINE void
1188 dict_free(item* head)
1189 {
1190     item* iterator = head;
1191
1192     while (iterator) {
1193         item* temp = iterator;
1194         iterator = iterator->next;
1195         Safefree(temp);
1196     }
1197
1198     head = NULL;
1199 }
1200
1201 /* End of Dictionary Stuff */
1202
1203 /* All calculations/work are done here */
1204 STATIC int
1205 S_edit_distance(const UV* src,
1206                 const UV* tgt,
1207                 const STRLEN x,             /* length of src[] */
1208                 const STRLEN y,             /* length of tgt[] */
1209                 const SSize_t maxDistance
1210 )
1211 {
1212     item *head = NULL;
1213     UV swapCount,swapScore,targetCharCount,i,j;
1214     UV *scores;
1215     UV score_ceil = x + y;
1216
1217     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1218
1219     /* intialize matrix start values */
1220     Newx(scores, ( (x + 2) * (y + 2)), UV);
1221     scores[0] = score_ceil;
1222     scores[1 * (y + 2) + 0] = score_ceil;
1223     scores[0 * (y + 2) + 1] = score_ceil;
1224     scores[1 * (y + 2) + 1] = 0;
1225     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1226
1227     /* work loops    */
1228     /* i = src index */
1229     /* j = tgt index */
1230     for (i=1;i<=x;i++) {
1231         if (i < x)
1232             head = uniquePush(head,src[i]);
1233         scores[(i+1) * (y + 2) + 1] = i;
1234         scores[(i+1) * (y + 2) + 0] = score_ceil;
1235         swapCount = 0;
1236
1237         for (j=1;j<=y;j++) {
1238             if (i == 1) {
1239                 if(j < y)
1240                 head = uniquePush(head,tgt[j]);
1241                 scores[1 * (y + 2) + (j + 1)] = j;
1242                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1243             }
1244
1245             targetCharCount = find(head,tgt[j-1])->value;
1246             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1247
1248             if (src[i-1] != tgt[j-1]){
1249                 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));
1250             }
1251             else {
1252                 swapCount = j;
1253                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1254             }
1255         }
1256
1257         find(head,src[i-1])->value = i;
1258     }
1259
1260     {
1261         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1262         dict_free(head);
1263         Safefree(scores);
1264         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1265     }
1266 }
1267
1268 /* END of edit_distance() stuff
1269  * ========================================================= */
1270
1271 /* is c a control character for which we have a mnemonic? */
1272 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1273
1274 STATIC const char *
1275 S_cntrl_to_mnemonic(const U8 c)
1276 {
1277     /* Returns the mnemonic string that represents character 'c', if one
1278      * exists; NULL otherwise.  The only ones that exist for the purposes of
1279      * this routine are a few control characters */
1280
1281     switch (c) {
1282         case '\a':       return "\\a";
1283         case '\b':       return "\\b";
1284         case ESC_NATIVE: return "\\e";
1285         case '\f':       return "\\f";
1286         case '\n':       return "\\n";
1287         case '\r':       return "\\r";
1288         case '\t':       return "\\t";
1289     }
1290
1291     return NULL;
1292 }
1293
1294 /* Mark that we cannot extend a found fixed substring at this point.
1295    Update the longest found anchored substring or the longest found
1296    floating substrings if needed. */
1297
1298 STATIC void
1299 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1300                     SSize_t *minlenp, int is_inf)
1301 {
1302     const STRLEN l = CHR_SVLEN(data->last_found);
1303     SV * const longest_sv = data->substrs[data->cur_is_floating].str;
1304     const STRLEN old_l = CHR_SVLEN(longest_sv);
1305     GET_RE_DEBUG_FLAGS_DECL;
1306
1307     PERL_ARGS_ASSERT_SCAN_COMMIT;
1308
1309     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1310         const U8 i = data->cur_is_floating;
1311         SvSetMagicSV(longest_sv, data->last_found);
1312         data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min;
1313
1314         if (!i) /* fixed */
1315             data->substrs[0].max_offset = data->substrs[0].min_offset;
1316         else { /* float */
1317             data->substrs[1].max_offset = (l
1318                           ? data->last_start_max
1319                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1320                                          ? SSize_t_MAX
1321                                          : data->pos_min + data->pos_delta));
1322             if (is_inf
1323                  || (STRLEN)data->substrs[1].max_offset > (STRLEN)SSize_t_MAX)
1324                 data->substrs[1].max_offset = SSize_t_MAX;
1325         }
1326
1327         if (data->flags & SF_BEFORE_EOL)
1328             data->substrs[i].flags |= (data->flags & SF_BEFORE_EOL);
1329         else
1330             data->substrs[i].flags &= ~SF_BEFORE_EOL;
1331         data->substrs[i].minlenp = minlenp;
1332         data->substrs[i].lookbehind = 0;
1333     }
1334
1335     SvCUR_set(data->last_found, 0);
1336     {
1337         SV * const sv = data->last_found;
1338         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1339             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1340             if (mg)
1341                 mg->mg_len = 0;
1342         }
1343     }
1344     data->last_end = -1;
1345     data->flags &= ~SF_BEFORE_EOL;
1346     DEBUG_STUDYDATA("commit", data, 0, is_inf);
1347 }
1348
1349 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1350  * list that describes which code points it matches */
1351
1352 STATIC void
1353 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1354 {
1355     /* Set the SSC 'ssc' to match an empty string or any code point */
1356
1357     PERL_ARGS_ASSERT_SSC_ANYTHING;
1358
1359     assert(is_ANYOF_SYNTHETIC(ssc));
1360
1361     /* mortalize so won't leak */
1362     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1363     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1364 }
1365
1366 STATIC int
1367 S_ssc_is_anything(const regnode_ssc *ssc)
1368 {
1369     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1370      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1371      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1372      * in any way, so there's no point in using it */
1373
1374     UV start, end;
1375     bool ret;
1376
1377     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1378
1379     assert(is_ANYOF_SYNTHETIC(ssc));
1380
1381     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1382         return FALSE;
1383     }
1384
1385     /* See if the list consists solely of the range 0 - Infinity */
1386     invlist_iterinit(ssc->invlist);
1387     ret = invlist_iternext(ssc->invlist, &start, &end)
1388           && start == 0
1389           && end == UV_MAX;
1390
1391     invlist_iterfinish(ssc->invlist);
1392
1393     if (ret) {
1394         return TRUE;
1395     }
1396
1397     /* If e.g., both \w and \W are set, matches everything */
1398     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1399         int i;
1400         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1401             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1402                 return TRUE;
1403             }
1404         }
1405     }
1406
1407     return FALSE;
1408 }
1409
1410 STATIC void
1411 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1412 {
1413     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1414      * string, any code point, or any posix class under locale */
1415
1416     PERL_ARGS_ASSERT_SSC_INIT;
1417
1418     Zero(ssc, 1, regnode_ssc);
1419     set_ANYOF_SYNTHETIC(ssc);
1420     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1421     ssc_anything(ssc);
1422
1423     /* If any portion of the regex is to operate under locale rules that aren't
1424      * fully known at compile time, initialization includes it.  The reason
1425      * this isn't done for all regexes is that the optimizer was written under
1426      * the assumption that locale was all-or-nothing.  Given the complexity and
1427      * lack of documentation in the optimizer, and that there are inadequate
1428      * test cases for locale, many parts of it may not work properly, it is
1429      * safest to avoid locale unless necessary. */
1430     if (RExC_contains_locale) {
1431         ANYOF_POSIXL_SETALL(ssc);
1432     }
1433     else {
1434         ANYOF_POSIXL_ZERO(ssc);
1435     }
1436 }
1437
1438 STATIC int
1439 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1440                         const regnode_ssc *ssc)
1441 {
1442     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1443      * to the list of code points matched, and locale posix classes; hence does
1444      * not check its flags) */
1445
1446     UV start, end;
1447     bool ret;
1448
1449     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1450
1451     assert(is_ANYOF_SYNTHETIC(ssc));
1452
1453     invlist_iterinit(ssc->invlist);
1454     ret = invlist_iternext(ssc->invlist, &start, &end)
1455           && start == 0
1456           && end == UV_MAX;
1457
1458     invlist_iterfinish(ssc->invlist);
1459
1460     if (! ret) {
1461         return FALSE;
1462     }
1463
1464     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1465         return FALSE;
1466     }
1467
1468     return TRUE;
1469 }
1470
1471 STATIC SV*
1472 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1473                                const regnode_charclass* const node)
1474 {
1475     /* Returns a mortal inversion list defining which code points are matched
1476      * by 'node', which is of type ANYOF.  Handles complementing the result if
1477      * appropriate.  If some code points aren't knowable at this time, the
1478      * returned list must, and will, contain every code point that is a
1479      * possibility. */
1480
1481     SV* invlist = NULL;
1482     SV* only_utf8_locale_invlist = NULL;
1483     unsigned int i;
1484     const U32 n = ARG(node);
1485     bool new_node_has_latin1 = FALSE;
1486
1487     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1488
1489     /* Look at the data structure created by S_set_ANYOF_arg() */
1490     if (n != ANYOF_ONLY_HAS_BITMAP) {
1491         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1492         AV * const av = MUTABLE_AV(SvRV(rv));
1493         SV **const ary = AvARRAY(av);
1494         assert(RExC_rxi->data->what[n] == 's');
1495
1496         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1497             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1498         }
1499         else if (ary[0] && ary[0] != &PL_sv_undef) {
1500
1501             /* Here, no compile-time swash, and there are things that won't be
1502              * known until runtime -- we have to assume it could be anything */
1503             invlist = sv_2mortal(_new_invlist(1));
1504             return _add_range_to_invlist(invlist, 0, UV_MAX);
1505         }
1506         else if (ary[3] && ary[3] != &PL_sv_undef) {
1507
1508             /* Here no compile-time swash, and no run-time only data.  Use the
1509              * node's inversion list */
1510             invlist = sv_2mortal(invlist_clone(ary[3]));
1511         }
1512
1513         /* Get the code points valid only under UTF-8 locales */
1514         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1515             && ary[2] && ary[2] != &PL_sv_undef)
1516         {
1517             only_utf8_locale_invlist = ary[2];
1518         }
1519     }
1520
1521     if (! invlist) {
1522         invlist = sv_2mortal(_new_invlist(0));
1523     }
1524
1525     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1526      * code points, and an inversion list for the others, but if there are code
1527      * points that should match only conditionally on the target string being
1528      * UTF-8, those are placed in the inversion list, and not the bitmap.
1529      * Since there are circumstances under which they could match, they are
1530      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1531      * to exclude them here, so that when we invert below, the end result
1532      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1533      * have to do this here before we add the unconditionally matched code
1534      * points */
1535     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1536         _invlist_intersection_complement_2nd(invlist,
1537                                              PL_UpperLatin1,
1538                                              &invlist);
1539     }
1540
1541     /* Add in the points from the bit map */
1542     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1543         if (ANYOF_BITMAP_TEST(node, i)) {
1544             unsigned int start = i++;
1545
1546             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1547                 /* empty */
1548             }
1549             invlist = _add_range_to_invlist(invlist, start, i-1);
1550             new_node_has_latin1 = TRUE;
1551         }
1552     }
1553
1554     /* If this can match all upper Latin1 code points, have to add them
1555      * as well.  But don't add them if inverting, as when that gets done below,
1556      * it would exclude all these characters, including the ones it shouldn't
1557      * that were added just above */
1558     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1559         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1560     {
1561         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1562     }
1563
1564     /* Similarly for these */
1565     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1566         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1567     }
1568
1569     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1570         _invlist_invert(invlist);
1571     }
1572     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1573
1574         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1575          * locale.  We can skip this if there are no 0-255 at all. */
1576         _invlist_union(invlist, PL_Latin1, &invlist);
1577     }
1578
1579     /* Similarly add the UTF-8 locale possible matches.  These have to be
1580      * deferred until after the non-UTF-8 locale ones are taken care of just
1581      * above, or it leads to wrong results under ANYOF_INVERT */
1582     if (only_utf8_locale_invlist) {
1583         _invlist_union_maybe_complement_2nd(invlist,
1584                                             only_utf8_locale_invlist,
1585                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1586                                             &invlist);
1587     }
1588
1589     return invlist;
1590 }
1591
1592 /* These two functions currently do the exact same thing */
1593 #define ssc_init_zero           ssc_init
1594
1595 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1596 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1597
1598 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1599  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1600  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1601
1602 STATIC void
1603 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1604                 const regnode_charclass *and_with)
1605 {
1606     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1607      * another SSC or a regular ANYOF class.  Can create false positives. */
1608
1609     SV* anded_cp_list;
1610     U8  anded_flags;
1611
1612     PERL_ARGS_ASSERT_SSC_AND;
1613
1614     assert(is_ANYOF_SYNTHETIC(ssc));
1615
1616     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1617      * the code point inversion list and just the relevant flags */
1618     if (is_ANYOF_SYNTHETIC(and_with)) {
1619         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1620         anded_flags = ANYOF_FLAGS(and_with);
1621
1622         /* XXX This is a kludge around what appears to be deficiencies in the
1623          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1624          * there are paths through the optimizer where it doesn't get weeded
1625          * out when it should.  And if we don't make some extra provision for
1626          * it like the code just below, it doesn't get added when it should.
1627          * This solution is to add it only when AND'ing, which is here, and
1628          * only when what is being AND'ed is the pristine, original node
1629          * matching anything.  Thus it is like adding it to ssc_anything() but
1630          * only when the result is to be AND'ed.  Probably the same solution
1631          * could be adopted for the same problem we have with /l matching,
1632          * which is solved differently in S_ssc_init(), and that would lead to
1633          * fewer false positives than that solution has.  But if this solution
1634          * creates bugs, the consequences are only that a warning isn't raised
1635          * that should be; while the consequences for having /l bugs is
1636          * incorrect matches */
1637         if (ssc_is_anything((regnode_ssc *)and_with)) {
1638             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1639         }
1640     }
1641     else {
1642         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1643         if (OP(and_with) == ANYOFD) {
1644             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1645         }
1646         else {
1647             anded_flags = ANYOF_FLAGS(and_with)
1648             &( ANYOF_COMMON_FLAGS
1649               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1650               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1651             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1652                 anded_flags &=
1653                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1654             }
1655         }
1656     }
1657
1658     ANYOF_FLAGS(ssc) &= anded_flags;
1659
1660     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1661      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1662      * 'and_with' may be inverted.  When not inverted, we have the situation of
1663      * computing:
1664      *  (C1 | P1) & (C2 | P2)
1665      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1666      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1667      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1668      *                    <=  ((C1 & C2) | P1 | P2)
1669      * Alternatively, the last few steps could be:
1670      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1671      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1672      *                    <=  (C1 | C2 | (P1 & P2))
1673      * We favor the second approach if either P1 or P2 is non-empty.  This is
1674      * because these components are a barrier to doing optimizations, as what
1675      * they match cannot be known until the moment of matching as they are
1676      * dependent on the current locale, 'AND"ing them likely will reduce or
1677      * eliminate them.
1678      * But we can do better if we know that C1,P1 are in their initial state (a
1679      * frequent occurrence), each matching everything:
1680      *  (<everything>) & (C2 | P2) =  C2 | P2
1681      * Similarly, if C2,P2 are in their initial state (again a frequent
1682      * occurrence), the result is a no-op
1683      *  (C1 | P1) & (<everything>) =  C1 | P1
1684      *
1685      * Inverted, we have
1686      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1687      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1688      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1689      * */
1690
1691     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1692         && ! is_ANYOF_SYNTHETIC(and_with))
1693     {
1694         unsigned int i;
1695
1696         ssc_intersection(ssc,
1697                          anded_cp_list,
1698                          FALSE /* Has already been inverted */
1699                          );
1700
1701         /* If either P1 or P2 is empty, the intersection will be also; can skip
1702          * the loop */
1703         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1704             ANYOF_POSIXL_ZERO(ssc);
1705         }
1706         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1707
1708             /* Note that the Posix class component P from 'and_with' actually
1709              * looks like:
1710              *      P = Pa | Pb | ... | Pn
1711              * where each component is one posix class, such as in [\w\s].
1712              * Thus
1713              *      ~P = ~(Pa | Pb | ... | Pn)
1714              *         = ~Pa & ~Pb & ... & ~Pn
1715              *        <= ~Pa | ~Pb | ... | ~Pn
1716              * The last is something we can easily calculate, but unfortunately
1717              * is likely to have many false positives.  We could do better
1718              * in some (but certainly not all) instances if two classes in
1719              * P have known relationships.  For example
1720              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1721              * So
1722              *      :lower: & :print: = :lower:
1723              * And similarly for classes that must be disjoint.  For example,
1724              * since \s and \w can have no elements in common based on rules in
1725              * the POSIX standard,
1726              *      \w & ^\S = nothing
1727              * Unfortunately, some vendor locales do not meet the Posix
1728              * standard, in particular almost everything by Microsoft.
1729              * The loop below just changes e.g., \w into \W and vice versa */
1730
1731             regnode_charclass_posixl temp;
1732             int add = 1;    /* To calculate the index of the complement */
1733
1734             Zero(&temp, 1, regnode_charclass_posixl);
1735             ANYOF_POSIXL_ZERO(&temp);
1736             for (i = 0; i < ANYOF_MAX; i++) {
1737                 assert(i % 2 != 0
1738                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1739                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1740
1741                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1742                     ANYOF_POSIXL_SET(&temp, i + add);
1743                 }
1744                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1745             }
1746             ANYOF_POSIXL_AND(&temp, ssc);
1747
1748         } /* else ssc already has no posixes */
1749     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1750          in its initial state */
1751     else if (! is_ANYOF_SYNTHETIC(and_with)
1752              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1753     {
1754         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1755          * copy it over 'ssc' */
1756         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1757             if (is_ANYOF_SYNTHETIC(and_with)) {
1758                 StructCopy(and_with, ssc, regnode_ssc);
1759             }
1760             else {
1761                 ssc->invlist = anded_cp_list;
1762                 ANYOF_POSIXL_ZERO(ssc);
1763                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1764                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1765                 }
1766             }
1767         }
1768         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1769                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1770         {
1771             /* One or the other of P1, P2 is non-empty. */
1772             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1773                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1774             }
1775             ssc_union(ssc, anded_cp_list, FALSE);
1776         }
1777         else { /* P1 = P2 = empty */
1778             ssc_intersection(ssc, anded_cp_list, FALSE);
1779         }
1780     }
1781 }
1782
1783 STATIC void
1784 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1785                const regnode_charclass *or_with)
1786 {
1787     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1788      * another SSC or a regular ANYOF class.  Can create false positives if
1789      * 'or_with' is to be inverted. */
1790
1791     SV* ored_cp_list;
1792     U8 ored_flags;
1793
1794     PERL_ARGS_ASSERT_SSC_OR;
1795
1796     assert(is_ANYOF_SYNTHETIC(ssc));
1797
1798     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1799      * the code point inversion list and just the relevant flags */
1800     if (is_ANYOF_SYNTHETIC(or_with)) {
1801         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1802         ored_flags = ANYOF_FLAGS(or_with);
1803     }
1804     else {
1805         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1806         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1807         if (OP(or_with) != ANYOFD) {
1808             ored_flags
1809             |= ANYOF_FLAGS(or_with)
1810              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1811                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1812             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1813                 ored_flags |=
1814                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1815             }
1816         }
1817     }
1818
1819     ANYOF_FLAGS(ssc) |= ored_flags;
1820
1821     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1822      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1823      * 'or_with' may be inverted.  When not inverted, we have the simple
1824      * situation of computing:
1825      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1826      * If P1|P2 yields a situation with both a class and its complement are
1827      * set, like having both \w and \W, this matches all code points, and we
1828      * can delete these from the P component of the ssc going forward.  XXX We
1829      * might be able to delete all the P components, but I (khw) am not certain
1830      * about this, and it is better to be safe.
1831      *
1832      * Inverted, we have
1833      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1834      *                         <=  (C1 | P1) | ~C2
1835      *                         <=  (C1 | ~C2) | P1
1836      * (which results in actually simpler code than the non-inverted case)
1837      * */
1838
1839     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1840         && ! is_ANYOF_SYNTHETIC(or_with))
1841     {
1842         /* We ignore P2, leaving P1 going forward */
1843     }   /* else  Not inverted */
1844     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1845         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1846         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1847             unsigned int i;
1848             for (i = 0; i < ANYOF_MAX; i += 2) {
1849                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1850                 {
1851                     ssc_match_all_cp(ssc);
1852                     ANYOF_POSIXL_CLEAR(ssc, i);
1853                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1854                 }
1855             }
1856         }
1857     }
1858
1859     ssc_union(ssc,
1860               ored_cp_list,
1861               FALSE /* Already has been inverted */
1862               );
1863 }
1864
1865 PERL_STATIC_INLINE void
1866 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1867 {
1868     PERL_ARGS_ASSERT_SSC_UNION;
1869
1870     assert(is_ANYOF_SYNTHETIC(ssc));
1871
1872     _invlist_union_maybe_complement_2nd(ssc->invlist,
1873                                         invlist,
1874                                         invert2nd,
1875                                         &ssc->invlist);
1876 }
1877
1878 PERL_STATIC_INLINE void
1879 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1880                          SV* const invlist,
1881                          const bool invert2nd)
1882 {
1883     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1884
1885     assert(is_ANYOF_SYNTHETIC(ssc));
1886
1887     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1888                                                invlist,
1889                                                invert2nd,
1890                                                &ssc->invlist);
1891 }
1892
1893 PERL_STATIC_INLINE void
1894 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1895 {
1896     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1897
1898     assert(is_ANYOF_SYNTHETIC(ssc));
1899
1900     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1901 }
1902
1903 PERL_STATIC_INLINE void
1904 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1905 {
1906     /* AND just the single code point 'cp' into the SSC 'ssc' */
1907
1908     SV* cp_list = _new_invlist(2);
1909
1910     PERL_ARGS_ASSERT_SSC_CP_AND;
1911
1912     assert(is_ANYOF_SYNTHETIC(ssc));
1913
1914     cp_list = add_cp_to_invlist(cp_list, cp);
1915     ssc_intersection(ssc, cp_list,
1916                      FALSE /* Not inverted */
1917                      );
1918     SvREFCNT_dec_NN(cp_list);
1919 }
1920
1921 PERL_STATIC_INLINE void
1922 S_ssc_clear_locale(regnode_ssc *ssc)
1923 {
1924     /* Set the SSC 'ssc' to not match any locale things */
1925     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1926
1927     assert(is_ANYOF_SYNTHETIC(ssc));
1928
1929     ANYOF_POSIXL_ZERO(ssc);
1930     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1931 }
1932
1933 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1934
1935 STATIC bool
1936 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1937 {
1938     /* The synthetic start class is used to hopefully quickly winnow down
1939      * places where a pattern could start a match in the target string.  If it
1940      * doesn't really narrow things down that much, there isn't much point to
1941      * having the overhead of using it.  This function uses some very crude
1942      * heuristics to decide if to use the ssc or not.
1943      *
1944      * It returns TRUE if 'ssc' rules out more than half what it considers to
1945      * be the "likely" possible matches, but of course it doesn't know what the
1946      * actual things being matched are going to be; these are only guesses
1947      *
1948      * For /l matches, it assumes that the only likely matches are going to be
1949      *      in the 0-255 range, uniformly distributed, so half of that is 127
1950      * For /a and /d matches, it assumes that the likely matches will be just
1951      *      the ASCII range, so half of that is 63
1952      * For /u and there isn't anything matching above the Latin1 range, it
1953      *      assumes that that is the only range likely to be matched, and uses
1954      *      half that as the cut-off: 127.  If anything matches above Latin1,
1955      *      it assumes that all of Unicode could match (uniformly), except for
1956      *      non-Unicode code points and things in the General Category "Other"
1957      *      (unassigned, private use, surrogates, controls and formats).  This
1958      *      is a much large number. */
1959
1960     U32 count = 0;      /* Running total of number of code points matched by
1961                            'ssc' */
1962     UV start, end;      /* Start and end points of current range in inversion
1963                            list */
1964     const U32 max_code_points = (LOC)
1965                                 ?  256
1966                                 : ((   ! UNI_SEMANTICS
1967                                      || invlist_highest(ssc->invlist) < 256)
1968                                   ? 128
1969                                   : NON_OTHER_COUNT);
1970     const U32 max_match = max_code_points / 2;
1971
1972     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1973
1974     invlist_iterinit(ssc->invlist);
1975     while (invlist_iternext(ssc->invlist, &start, &end)) {
1976         if (start >= max_code_points) {
1977             break;
1978         }
1979         end = MIN(end, max_code_points - 1);
1980         count += end - start + 1;
1981         if (count >= max_match) {
1982             invlist_iterfinish(ssc->invlist);
1983             return FALSE;
1984         }
1985     }
1986
1987     return TRUE;
1988 }
1989
1990
1991 STATIC void
1992 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1993 {
1994     /* The inversion list in the SSC is marked mortal; now we need a more
1995      * permanent copy, which is stored the same way that is done in a regular
1996      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1997      * map */
1998
1999     SV* invlist = invlist_clone(ssc->invlist);
2000
2001     PERL_ARGS_ASSERT_SSC_FINALIZE;
2002
2003     assert(is_ANYOF_SYNTHETIC(ssc));
2004
2005     /* The code in this file assumes that all but these flags aren't relevant
2006      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
2007      * by the time we reach here */
2008     assert(! (ANYOF_FLAGS(ssc)
2009         & ~( ANYOF_COMMON_FLAGS
2010             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
2011             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
2012
2013     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
2014
2015     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
2016                                 NULL, NULL, NULL, FALSE);
2017
2018     /* Make sure is clone-safe */
2019     ssc->invlist = NULL;
2020
2021     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
2022         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
2023     }
2024
2025     if (RExC_contains_locale) {
2026         OP(ssc) = ANYOFL;
2027     }
2028
2029     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
2030 }
2031
2032 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
2033 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
2034 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
2035 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
2036                                ? (TRIE_LIST_CUR( idx ) - 1)           \
2037                                : 0 )
2038
2039
2040 #ifdef DEBUGGING
2041 /*
2042    dump_trie(trie,widecharmap,revcharmap)
2043    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
2044    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
2045
2046    These routines dump out a trie in a somewhat readable format.
2047    The _interim_ variants are used for debugging the interim
2048    tables that are used to generate the final compressed
2049    representation which is what dump_trie expects.
2050
2051    Part of the reason for their existence is to provide a form
2052    of documentation as to how the different representations function.
2053
2054 */
2055
2056 /*
2057   Dumps the final compressed table form of the trie to Perl_debug_log.
2058   Used for debugging make_trie().
2059 */
2060
2061 STATIC void
2062 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
2063             AV *revcharmap, U32 depth)
2064 {
2065     U32 state;
2066     SV *sv=sv_newmortal();
2067     int colwidth= widecharmap ? 6 : 4;
2068     U16 word;
2069     GET_RE_DEBUG_FLAGS_DECL;
2070
2071     PERL_ARGS_ASSERT_DUMP_TRIE;
2072
2073     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
2074         depth+1, "Match","Base","Ofs" );
2075
2076     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
2077         SV ** const tmp = av_fetch( revcharmap, state, 0);
2078         if ( tmp ) {
2079             Perl_re_printf( aTHX_  "%*s",
2080                 colwidth,
2081                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2082                             PL_colors[0], PL_colors[1],
2083                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2084                             PERL_PV_ESCAPE_FIRSTCHAR
2085                 )
2086             );
2087         }
2088     }
2089     Perl_re_printf( aTHX_  "\n");
2090     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2091
2092     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2093         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2094     Perl_re_printf( aTHX_  "\n");
2095
2096     for( state = 1 ; state < trie->statecount ; state++ ) {
2097         const U32 base = trie->states[ state ].trans.base;
2098
2099         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2100
2101         if ( trie->states[ state ].wordnum ) {
2102             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2103         } else {
2104             Perl_re_printf( aTHX_  "%6s", "" );
2105         }
2106
2107         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2108
2109         if ( base ) {
2110             U32 ofs = 0;
2111
2112             while( ( base + ofs  < trie->uniquecharcount ) ||
2113                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2114                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2115                                                                     != state))
2116                     ofs++;
2117
2118             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2119
2120             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2121                 if ( ( base + ofs >= trie->uniquecharcount )
2122                         && ( base + ofs - trie->uniquecharcount
2123                                                         < trie->lasttrans )
2124                         && trie->trans[ base + ofs
2125                                     - trie->uniquecharcount ].check == state )
2126                 {
2127                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2128                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2129                    );
2130                 } else {
2131                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2132                 }
2133             }
2134
2135             Perl_re_printf( aTHX_  "]");
2136
2137         }
2138         Perl_re_printf( aTHX_  "\n" );
2139     }
2140     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2141                                 depth);
2142     for (word=1; word <= trie->wordcount; word++) {
2143         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2144             (int)word, (int)(trie->wordinfo[word].prev),
2145             (int)(trie->wordinfo[word].len));
2146     }
2147     Perl_re_printf( aTHX_  "\n" );
2148 }
2149 /*
2150   Dumps a fully constructed but uncompressed trie in list form.
2151   List tries normally only are used for construction when the number of
2152   possible chars (trie->uniquecharcount) is very high.
2153   Used for debugging make_trie().
2154 */
2155 STATIC void
2156 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2157                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2158                          U32 depth)
2159 {
2160     U32 state;
2161     SV *sv=sv_newmortal();
2162     int colwidth= widecharmap ? 6 : 4;
2163     GET_RE_DEBUG_FLAGS_DECL;
2164
2165     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2166
2167     /* print out the table precompression.  */
2168     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2169             depth+1 );
2170     Perl_re_indentf( aTHX_  "%s",
2171             depth+1, "------:-----+-----------------\n" );
2172
2173     for( state=1 ; state < next_alloc ; state ++ ) {
2174         U16 charid;
2175
2176         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2177             depth+1, (UV)state  );
2178         if ( ! trie->states[ state ].wordnum ) {
2179             Perl_re_printf( aTHX_  "%5s| ","");
2180         } else {
2181             Perl_re_printf( aTHX_  "W%4x| ",
2182                 trie->states[ state ].wordnum
2183             );
2184         }
2185         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2186             SV ** const tmp = av_fetch( revcharmap,
2187                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2188             if ( tmp ) {
2189                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2190                     colwidth,
2191                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2192                               colwidth,
2193                               PL_colors[0], PL_colors[1],
2194                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2195                               | PERL_PV_ESCAPE_FIRSTCHAR
2196                     ) ,
2197                     TRIE_LIST_ITEM(state,charid).forid,
2198                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2199                 );
2200                 if (!(charid % 10))
2201                     Perl_re_printf( aTHX_  "\n%*s| ",
2202                         (int)((depth * 2) + 14), "");
2203             }
2204         }
2205         Perl_re_printf( aTHX_  "\n");
2206     }
2207 }
2208
2209 /*
2210   Dumps a fully constructed but uncompressed trie in table form.
2211   This is the normal DFA style state transition table, with a few
2212   twists to facilitate compression later.
2213   Used for debugging make_trie().
2214 */
2215 STATIC void
2216 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2217                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2218                           U32 depth)
2219 {
2220     U32 state;
2221     U16 charid;
2222     SV *sv=sv_newmortal();
2223     int colwidth= widecharmap ? 6 : 4;
2224     GET_RE_DEBUG_FLAGS_DECL;
2225
2226     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2227
2228     /*
2229        print out the table precompression so that we can do a visual check
2230        that they are identical.
2231      */
2232
2233     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2234
2235     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2236         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2237         if ( tmp ) {
2238             Perl_re_printf( aTHX_  "%*s",
2239                 colwidth,
2240                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2241                             PL_colors[0], PL_colors[1],
2242                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2243                             PERL_PV_ESCAPE_FIRSTCHAR
2244                 )
2245             );
2246         }
2247     }
2248
2249     Perl_re_printf( aTHX_ "\n");
2250     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2251
2252     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2253         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2254     }
2255
2256     Perl_re_printf( aTHX_  "\n" );
2257
2258     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2259
2260         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2261             depth+1,
2262             (UV)TRIE_NODENUM( state ) );
2263
2264         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2265             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2266             if (v)
2267                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2268             else
2269                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2270         }
2271         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2272             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2273                                             (UV)trie->trans[ state ].check );
2274         } else {
2275             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2276                                             (UV)trie->trans[ state ].check,
2277             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2278         }
2279     }
2280 }
2281
2282 #endif
2283
2284
2285 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2286   startbranch: the first branch in the whole branch sequence
2287   first      : start branch of sequence of branch-exact nodes.
2288                May be the same as startbranch
2289   last       : Thing following the last branch.
2290                May be the same as tail.
2291   tail       : item following the branch sequence
2292   count      : words in the sequence
2293   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2294   depth      : indent depth
2295
2296 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2297
2298 A trie is an N'ary tree where the branches are determined by digital
2299 decomposition of the key. IE, at the root node you look up the 1st character and
2300 follow that branch repeat until you find the end of the branches. Nodes can be
2301 marked as "accepting" meaning they represent a complete word. Eg:
2302
2303   /he|she|his|hers/
2304
2305 would convert into the following structure. Numbers represent states, letters
2306 following numbers represent valid transitions on the letter from that state, if
2307 the number is in square brackets it represents an accepting state, otherwise it
2308 will be in parenthesis.
2309
2310       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2311       |    |
2312       |   (2)
2313       |    |
2314      (1)   +-i->(6)-+-s->[7]
2315       |
2316       +-s->(3)-+-h->(4)-+-e->[5]
2317
2318       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2319
2320 This shows that when matching against the string 'hers' we will begin at state 1
2321 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2322 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2323 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2324 single traverse. We store a mapping from accepting to state to which word was
2325 matched, and then when we have multiple possibilities we try to complete the
2326 rest of the regex in the order in which they occurred in the alternation.
2327
2328 The only prior NFA like behaviour that would be changed by the TRIE support is
2329 the silent ignoring of duplicate alternations which are of the form:
2330
2331  / (DUPE|DUPE) X? (?{ ... }) Y /x
2332
2333 Thus EVAL blocks following a trie may be called a different number of times with
2334 and without the optimisation. With the optimisations dupes will be silently
2335 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2336 the following demonstrates:
2337
2338  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2339
2340 which prints out 'word' three times, but
2341
2342  'words'=~/(word|word|word)(?{ print $1 })S/
2343
2344 which doesnt print it out at all. This is due to other optimisations kicking in.
2345
2346 Example of what happens on a structural level:
2347
2348 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2349
2350    1: CURLYM[1] {1,32767}(18)
2351    5:   BRANCH(8)
2352    6:     EXACT <ac>(16)
2353    8:   BRANCH(11)
2354    9:     EXACT <ad>(16)
2355   11:   BRANCH(14)
2356   12:     EXACT <ab>(16)
2357   16:   SUCCEED(0)
2358   17:   NOTHING(18)
2359   18: END(0)
2360
2361 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2362 and should turn into:
2363
2364    1: CURLYM[1] {1,32767}(18)
2365    5:   TRIE(16)
2366         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2367           <ac>
2368           <ad>
2369           <ab>
2370   16:   SUCCEED(0)
2371   17:   NOTHING(18)
2372   18: END(0)
2373
2374 Cases where tail != last would be like /(?foo|bar)baz/:
2375
2376    1: BRANCH(4)
2377    2:   EXACT <foo>(8)
2378    4: BRANCH(7)
2379    5:   EXACT <bar>(8)
2380    7: TAIL(8)
2381    8: EXACT <baz>(10)
2382   10: END(0)
2383
2384 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2385 and would end up looking like:
2386
2387     1: TRIE(8)
2388       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2389         <foo>
2390         <bar>
2391    7: TAIL(8)
2392    8: EXACT <baz>(10)
2393   10: END(0)
2394
2395     d = uvchr_to_utf8_flags(d, uv, 0);
2396
2397 is the recommended Unicode-aware way of saying
2398
2399     *(d++) = uv;
2400 */
2401
2402 #define TRIE_STORE_REVCHAR(val)                                            \
2403     STMT_START {                                                           \
2404         if (UTF) {                                                         \
2405             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2406             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2407             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2408             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2409             SvPOK_on(zlopp);                                               \
2410             SvUTF8_on(zlopp);                                              \
2411             av_push(revcharmap, zlopp);                                    \
2412         } else {                                                           \
2413             char ooooff = (char)val;                                           \
2414             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2415         }                                                                  \
2416         } STMT_END
2417
2418 /* This gets the next character from the input, folding it if not already
2419  * folded. */
2420 #define TRIE_READ_CHAR STMT_START {                                           \
2421     wordlen++;                                                                \
2422     if ( UTF ) {                                                              \
2423         /* if it is UTF then it is either already folded, or does not need    \
2424          * folding */                                                         \
2425         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2426     }                                                                         \
2427     else if (folder == PL_fold_latin1) {                                      \
2428         /* This folder implies Unicode rules, which in the range expressible  \
2429          *  by not UTF is the lower case, with the two exceptions, one of     \
2430          *  which should have been taken care of before calling this */       \
2431         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2432         uvc = toLOWER_L1(*uc);                                                \
2433         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2434         len = 1;                                                              \
2435     } else {                                                                  \
2436         /* raw data, will be folded later if needed */                        \
2437         uvc = (U32)*uc;                                                       \
2438         len = 1;                                                              \
2439     }                                                                         \
2440 } STMT_END
2441
2442
2443
2444 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2445     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2446         U32 ging = TRIE_LIST_LEN( state ) * 2;                  \
2447         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2448         TRIE_LIST_LEN( state ) = ging;                          \
2449     }                                                           \
2450     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2451     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2452     TRIE_LIST_CUR( state )++;                                   \
2453 } STMT_END
2454
2455 #define TRIE_LIST_NEW(state) STMT_START {                       \
2456     Newx( trie->states[ state ].trans.list,                     \
2457         4, reg_trie_trans_le );                                 \
2458      TRIE_LIST_CUR( state ) = 1;                                \
2459      TRIE_LIST_LEN( state ) = 4;                                \
2460 } STMT_END
2461
2462 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2463     U16 dupe= trie->states[ state ].wordnum;                    \
2464     regnode * const noper_next = regnext( noper );              \
2465                                                                 \
2466     DEBUG_r({                                                   \
2467         /* store the word for dumping */                        \
2468         SV* tmp;                                                \
2469         if (OP(noper) != NOTHING)                               \
2470             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2471         else                                                    \
2472             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2473         av_push( trie_words, tmp );                             \
2474     });                                                         \
2475                                                                 \
2476     curword++;                                                  \
2477     trie->wordinfo[curword].prev   = 0;                         \
2478     trie->wordinfo[curword].len    = wordlen;                   \
2479     trie->wordinfo[curword].accept = state;                     \
2480                                                                 \
2481     if ( noper_next < tail ) {                                  \
2482         if (!trie->jump)                                        \
2483             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2484                                                  sizeof(U16) ); \
2485         trie->jump[curword] = (U16)(noper_next - convert);      \
2486         if (!jumper)                                            \
2487             jumper = noper_next;                                \
2488         if (!nextbranch)                                        \
2489             nextbranch= regnext(cur);                           \
2490     }                                                           \
2491                                                                 \
2492     if ( dupe ) {                                               \
2493         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2494         /* chain, so that when the bits of chain are later    */\
2495         /* linked together, the dups appear in the chain      */\
2496         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2497         trie->wordinfo[dupe].prev = curword;                    \
2498     } else {                                                    \
2499         /* we haven't inserted this word yet.                */ \
2500         trie->states[ state ].wordnum = curword;                \
2501     }                                                           \
2502 } STMT_END
2503
2504
2505 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2506      ( ( base + charid >=  ucharcount                                   \
2507          && base + charid < ubound                                      \
2508          && state == trie->trans[ base - ucharcount + charid ].check    \
2509          && trie->trans[ base - ucharcount + charid ].next )            \
2510            ? trie->trans[ base - ucharcount + charid ].next             \
2511            : ( state==1 ? special : 0 )                                 \
2512       )
2513
2514 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2515 STMT_START {                                                \
2516     TRIE_BITMAP_SET(trie, uvc);                             \
2517     /* store the folded codepoint */                        \
2518     if ( folder )                                           \
2519         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2520                                                             \
2521     if ( !UTF ) {                                           \
2522         /* store first byte of utf8 representation of */    \
2523         /* variant codepoints */                            \
2524         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2525             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2526         }                                                   \
2527     }                                                       \
2528 } STMT_END
2529 #define MADE_TRIE       1
2530 #define MADE_JUMP_TRIE  2
2531 #define MADE_EXACT_TRIE 4
2532
2533 STATIC I32
2534 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2535                   regnode *first, regnode *last, regnode *tail,
2536                   U32 word_count, U32 flags, U32 depth)
2537 {
2538     /* first pass, loop through and scan words */
2539     reg_trie_data *trie;
2540     HV *widecharmap = NULL;
2541     AV *revcharmap = newAV();
2542     regnode *cur;
2543     STRLEN len = 0;
2544     UV uvc = 0;
2545     U16 curword = 0;
2546     U32 next_alloc = 0;
2547     regnode *jumper = NULL;
2548     regnode *nextbranch = NULL;
2549     regnode *convert = NULL;
2550     U32 *prev_states; /* temp array mapping each state to previous one */
2551     /* we just use folder as a flag in utf8 */
2552     const U8 * folder = NULL;
2553
2554     /* in the below add_data call we are storing either 'tu' or 'tuaa'
2555      * which stands for one trie structure, one hash, optionally followed
2556      * by two arrays */
2557 #ifdef DEBUGGING
2558     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuaa"));
2559     AV *trie_words = NULL;
2560     /* along with revcharmap, this only used during construction but both are
2561      * useful during debugging so we store them in the struct when debugging.
2562      */
2563 #else
2564     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2565     STRLEN trie_charcount=0;
2566 #endif
2567     SV *re_trie_maxbuff;
2568     GET_RE_DEBUG_FLAGS_DECL;
2569
2570     PERL_ARGS_ASSERT_MAKE_TRIE;
2571 #ifndef DEBUGGING
2572     PERL_UNUSED_ARG(depth);
2573 #endif
2574
2575     switch (flags) {
2576         case EXACT: case EXACTL: break;
2577         case EXACTFAA:
2578         case EXACTFU_SS:
2579         case EXACTFU:
2580         case EXACTFLU8: folder = PL_fold_latin1; break;
2581         case EXACTF:  folder = PL_fold; break;
2582         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2583     }
2584
2585     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2586     trie->refcount = 1;
2587     trie->startstate = 1;
2588     trie->wordcount = word_count;
2589     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2590     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2591     if (flags == EXACT || flags == EXACTL)
2592         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2593     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2594                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2595
2596     DEBUG_r({
2597         trie_words = newAV();
2598     });
2599
2600     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2601     assert(re_trie_maxbuff);
2602     if (!SvIOK(re_trie_maxbuff)) {
2603         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2604     }
2605     DEBUG_TRIE_COMPILE_r({
2606         Perl_re_indentf( aTHX_
2607           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2608           depth+1,
2609           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2610           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2611     });
2612
2613    /* Find the node we are going to overwrite */
2614     if ( first == startbranch && OP( last ) != BRANCH ) {
2615         /* whole branch chain */
2616         convert = first;
2617     } else {
2618         /* branch sub-chain */
2619         convert = NEXTOPER( first );
2620     }
2621
2622     /*  -- First loop and Setup --
2623
2624        We first traverse the branches and scan each word to determine if it
2625        contains widechars, and how many unique chars there are, this is
2626        important as we have to build a table with at least as many columns as we
2627        have unique chars.
2628
2629        We use an array of integers to represent the character codes 0..255
2630        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2631        the native representation of the character value as the key and IV's for
2632        the coded index.
2633
2634        *TODO* If we keep track of how many times each character is used we can
2635        remap the columns so that the table compression later on is more
2636        efficient in terms of memory by ensuring the most common value is in the
2637        middle and the least common are on the outside.  IMO this would be better
2638        than a most to least common mapping as theres a decent chance the most
2639        common letter will share a node with the least common, meaning the node
2640        will not be compressible. With a middle is most common approach the worst
2641        case is when we have the least common nodes twice.
2642
2643      */
2644
2645     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2646         regnode *noper = NEXTOPER( cur );
2647         const U8 *uc;
2648         const U8 *e;
2649         int foldlen = 0;
2650         U32 wordlen      = 0;         /* required init */
2651         STRLEN minchars = 0;
2652         STRLEN maxchars = 0;
2653         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2654                                                bitmap?*/
2655
2656         if (OP(noper) == NOTHING) {
2657             /* skip past a NOTHING at the start of an alternation
2658              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2659              */
2660             regnode *noper_next= regnext(noper);
2661             if (noper_next < tail)
2662                 noper= noper_next;
2663         }
2664
2665         if ( noper < tail &&
2666                 (
2667                     OP(noper) == flags ||
2668                     (
2669                         flags == EXACTFU &&
2670                         OP(noper) == EXACTFU_SS
2671                     )
2672                 )
2673         ) {
2674             uc= (U8*)STRING(noper);
2675             e= uc + STR_LEN(noper);
2676         } else {
2677             trie->minlen= 0;
2678             continue;
2679         }
2680
2681
2682         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2683             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2684                                           regardless of encoding */
2685             if (OP( noper ) == EXACTFU_SS) {
2686                 /* false positives are ok, so just set this */
2687                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2688             }
2689         }
2690
2691         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2692                                            branch */
2693             TRIE_CHARCOUNT(trie)++;
2694             TRIE_READ_CHAR;
2695
2696             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2697              * is in effect.  Under /i, this character can match itself, or
2698              * anything that folds to it.  If not under /i, it can match just
2699              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2700              * all fold to k, and all are single characters.   But some folds
2701              * expand to more than one character, so for example LATIN SMALL
2702              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2703              * the string beginning at 'uc' is 'ffi', it could be matched by
2704              * three characters, or just by the one ligature character. (It
2705              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2706              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2707              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2708              * match.)  The trie needs to know the minimum and maximum number
2709              * of characters that could match so that it can use size alone to
2710              * quickly reject many match attempts.  The max is simple: it is
2711              * the number of folded characters in this branch (since a fold is
2712              * never shorter than what folds to it. */
2713
2714             maxchars++;
2715
2716             /* And the min is equal to the max if not under /i (indicated by
2717              * 'folder' being NULL), or there are no multi-character folds.  If
2718              * there is a multi-character fold, the min is incremented just
2719              * once, for the character that folds to the sequence.  Each
2720              * character in the sequence needs to be added to the list below of
2721              * characters in the trie, but we count only the first towards the
2722              * min number of characters needed.  This is done through the
2723              * variable 'foldlen', which is returned by the macros that look
2724              * for these sequences as the number of bytes the sequence
2725              * occupies.  Each time through the loop, we decrement 'foldlen' by
2726              * how many bytes the current char occupies.  Only when it reaches
2727              * 0 do we increment 'minchars' or look for another multi-character
2728              * sequence. */
2729             if (folder == NULL) {
2730                 minchars++;
2731             }
2732             else if (foldlen > 0) {
2733                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2734             }
2735             else {
2736                 minchars++;
2737
2738                 /* See if *uc is the beginning of a multi-character fold.  If
2739                  * so, we decrement the length remaining to look at, to account
2740                  * for the current character this iteration.  (We can use 'uc'
2741                  * instead of the fold returned by TRIE_READ_CHAR because for
2742                  * non-UTF, the latin1_safe macro is smart enough to account
2743                  * for all the unfolded characters, and because for UTF, the
2744                  * string will already have been folded earlier in the
2745                  * compilation process */
2746                 if (UTF) {
2747                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2748                         foldlen -= UTF8SKIP(uc);
2749                     }
2750                 }
2751                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2752                     foldlen--;
2753                 }
2754             }
2755
2756             /* The current character (and any potential folds) should be added
2757              * to the possible matching characters for this position in this
2758              * branch */
2759             if ( uvc < 256 ) {
2760                 if ( folder ) {
2761                     U8 folded= folder[ (U8) uvc ];
2762                     if ( !trie->charmap[ folded ] ) {
2763                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2764                         TRIE_STORE_REVCHAR( folded );
2765                     }
2766                 }
2767                 if ( !trie->charmap[ uvc ] ) {
2768                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2769                     TRIE_STORE_REVCHAR( uvc );
2770                 }
2771                 if ( set_bit ) {
2772                     /* store the codepoint in the bitmap, and its folded
2773                      * equivalent. */
2774                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2775                     set_bit = 0; /* We've done our bit :-) */
2776                 }
2777             } else {
2778
2779                 /* XXX We could come up with the list of code points that fold
2780                  * to this using PL_utf8_foldclosures, except not for
2781                  * multi-char folds, as there may be multiple combinations
2782                  * there that could work, which needs to wait until runtime to
2783                  * resolve (The comment about LIGATURE FFI above is such an
2784                  * example */
2785
2786                 SV** svpp;
2787                 if ( !widecharmap )
2788                     widecharmap = newHV();
2789
2790                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2791
2792                 if ( !svpp )
2793                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2794
2795                 if ( !SvTRUE( *svpp ) ) {
2796                     sv_setiv( *svpp, ++trie->uniquecharcount );
2797                     TRIE_STORE_REVCHAR(uvc);
2798                 }
2799             }
2800         } /* end loop through characters in this branch of the trie */
2801
2802         /* We take the min and max for this branch and combine to find the min
2803          * and max for all branches processed so far */
2804         if( cur == first ) {
2805             trie->minlen = minchars;
2806             trie->maxlen = maxchars;
2807         } else if (minchars < trie->minlen) {
2808             trie->minlen = minchars;
2809         } else if (maxchars > trie->maxlen) {
2810             trie->maxlen = maxchars;
2811         }
2812     } /* end first pass */
2813     DEBUG_TRIE_COMPILE_r(
2814         Perl_re_indentf( aTHX_
2815                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2816                 depth+1,
2817                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2818                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2819                 (int)trie->minlen, (int)trie->maxlen )
2820     );
2821
2822     /*
2823         We now know what we are dealing with in terms of unique chars and
2824         string sizes so we can calculate how much memory a naive
2825         representation using a flat table  will take. If it's over a reasonable
2826         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2827         conservative but potentially much slower representation using an array
2828         of lists.
2829
2830         At the end we convert both representations into the same compressed
2831         form that will be used in regexec.c for matching with. The latter
2832         is a form that cannot be used to construct with but has memory
2833         properties similar to the list form and access properties similar
2834         to the table form making it both suitable for fast searches and
2835         small enough that its feasable to store for the duration of a program.
2836
2837         See the comment in the code where the compressed table is produced
2838         inplace from the flat tabe representation for an explanation of how
2839         the compression works.
2840
2841     */
2842
2843
2844     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2845     prev_states[1] = 0;
2846
2847     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2848                                                     > SvIV(re_trie_maxbuff) )
2849     {
2850         /*
2851             Second Pass -- Array Of Lists Representation
2852
2853             Each state will be represented by a list of charid:state records
2854             (reg_trie_trans_le) the first such element holds the CUR and LEN
2855             points of the allocated array. (See defines above).
2856
2857             We build the initial structure using the lists, and then convert
2858             it into the compressed table form which allows faster lookups
2859             (but cant be modified once converted).
2860         */
2861
2862         STRLEN transcount = 1;
2863
2864         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2865             depth+1));
2866
2867         trie->states = (reg_trie_state *)
2868             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2869                                   sizeof(reg_trie_state) );
2870         TRIE_LIST_NEW(1);
2871         next_alloc = 2;
2872
2873         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2874
2875             regnode *noper   = NEXTOPER( cur );
2876             U32 state        = 1;         /* required init */
2877             U16 charid       = 0;         /* sanity init */
2878             U32 wordlen      = 0;         /* required init */
2879
2880             if (OP(noper) == NOTHING) {
2881                 regnode *noper_next= regnext(noper);
2882                 if (noper_next < tail)
2883                     noper= noper_next;
2884             }
2885
2886             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2887                 const U8 *uc= (U8*)STRING(noper);
2888                 const U8 *e= uc + STR_LEN(noper);
2889
2890                 for ( ; uc < e ; uc += len ) {
2891
2892                     TRIE_READ_CHAR;
2893
2894                     if ( uvc < 256 ) {
2895                         charid = trie->charmap[ uvc ];
2896                     } else {
2897                         SV** const svpp = hv_fetch( widecharmap,
2898                                                     (char*)&uvc,
2899                                                     sizeof( UV ),
2900                                                     0);
2901                         if ( !svpp ) {
2902                             charid = 0;
2903                         } else {
2904                             charid=(U16)SvIV( *svpp );
2905                         }
2906                     }
2907                     /* charid is now 0 if we dont know the char read, or
2908                      * nonzero if we do */
2909                     if ( charid ) {
2910
2911                         U16 check;
2912                         U32 newstate = 0;
2913
2914                         charid--;
2915                         if ( !trie->states[ state ].trans.list ) {
2916                             TRIE_LIST_NEW( state );
2917                         }
2918                         for ( check = 1;
2919                               check <= TRIE_LIST_USED( state );
2920                               check++ )
2921                         {
2922                             if ( TRIE_LIST_ITEM( state, check ).forid
2923                                                                     == charid )
2924                             {
2925                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2926                                 break;
2927                             }
2928                         }
2929                         if ( ! newstate ) {
2930                             newstate = next_alloc++;
2931                             prev_states[newstate] = state;
2932                             TRIE_LIST_PUSH( state, charid, newstate );
2933                             transcount++;
2934                         }
2935                         state = newstate;
2936                     } else {
2937                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2938                     }
2939                 }
2940             }
2941             TRIE_HANDLE_WORD(state);
2942
2943         } /* end second pass */
2944
2945         /* next alloc is the NEXT state to be allocated */
2946         trie->statecount = next_alloc;
2947         trie->states = (reg_trie_state *)
2948             PerlMemShared_realloc( trie->states,
2949                                    next_alloc
2950                                    * sizeof(reg_trie_state) );
2951
2952         /* and now dump it out before we compress it */
2953         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2954                                                          revcharmap, next_alloc,
2955                                                          depth+1)
2956         );
2957
2958         trie->trans = (reg_trie_trans *)
2959             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2960         {
2961             U32 state;
2962             U32 tp = 0;
2963             U32 zp = 0;
2964
2965
2966             for( state=1 ; state < next_alloc ; state ++ ) {
2967                 U32 base=0;
2968
2969                 /*
2970                 DEBUG_TRIE_COMPILE_MORE_r(
2971                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2972                 );
2973                 */
2974
2975                 if (trie->states[state].trans.list) {
2976                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2977                     U16 maxid=minid;
2978                     U16 idx;
2979
2980                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2981                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2982                         if ( forid < minid ) {
2983                             minid=forid;
2984                         } else if ( forid > maxid ) {
2985                             maxid=forid;
2986                         }
2987                     }
2988                     if ( transcount < tp + maxid - minid + 1) {
2989                         transcount *= 2;
2990                         trie->trans = (reg_trie_trans *)
2991                             PerlMemShared_realloc( trie->trans,
2992                                                      transcount
2993                                                      * sizeof(reg_trie_trans) );
2994                         Zero( trie->trans + (transcount / 2),
2995                               transcount / 2,
2996                               reg_trie_trans );
2997                     }
2998                     base = trie->uniquecharcount + tp - minid;
2999                     if ( maxid == minid ) {
3000                         U32 set = 0;
3001                         for ( ; zp < tp ; zp++ ) {
3002                             if ( ! trie->trans[ zp ].next ) {
3003                                 base = trie->uniquecharcount + zp - minid;
3004                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
3005                                                                    1).newstate;
3006                                 trie->trans[ zp ].check = state;
3007                                 set = 1;
3008                                 break;
3009                             }
3010                         }
3011                         if ( !set ) {
3012                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
3013                                                                    1).newstate;
3014                             trie->trans[ tp ].check = state;
3015                             tp++;
3016                             zp = tp;
3017                         }
3018                     } else {
3019                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3020                             const U32 tid = base
3021                                            - trie->uniquecharcount
3022                                            + TRIE_LIST_ITEM( state, idx ).forid;
3023                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
3024                                                                 idx ).newstate;
3025                             trie->trans[ tid ].check = state;
3026                         }
3027                         tp += ( maxid - minid + 1 );
3028                     }
3029                     Safefree(trie->states[ state ].trans.list);
3030                 }
3031                 /*
3032                 DEBUG_TRIE_COMPILE_MORE_r(
3033                     Perl_re_printf( aTHX_  " base: %d\n",base);
3034                 );
3035                 */
3036                 trie->states[ state ].trans.base=base;
3037             }
3038             trie->lasttrans = tp + 1;
3039         }
3040     } else {
3041         /*
3042            Second Pass -- Flat Table Representation.
3043
3044            we dont use the 0 slot of either trans[] or states[] so we add 1 to
3045            each.  We know that we will need Charcount+1 trans at most to store
3046            the data (one row per char at worst case) So we preallocate both
3047            structures assuming worst case.
3048
3049            We then construct the trie using only the .next slots of the entry
3050            structs.
3051
3052            We use the .check field of the first entry of the node temporarily
3053            to make compression both faster and easier by keeping track of how
3054            many non zero fields are in the node.
3055
3056            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
3057            transition.
3058
3059            There are two terms at use here: state as a TRIE_NODEIDX() which is
3060            a number representing the first entry of the node, and state as a
3061            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
3062            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
3063            if there are 2 entrys per node. eg:
3064
3065              A B       A B
3066           1. 2 4    1. 3 7
3067           2. 0 3    3. 0 5
3068           3. 0 0    5. 0 0
3069           4. 0 0    7. 0 0
3070
3071            The table is internally in the right hand, idx form. However as we
3072            also have to deal with the states array which is indexed by nodenum
3073            we have to use TRIE_NODENUM() to convert.
3074
3075         */
3076         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
3077             depth+1));
3078
3079         trie->trans = (reg_trie_trans *)
3080             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
3081                                   * trie->uniquecharcount + 1,
3082                                   sizeof(reg_trie_trans) );
3083         trie->states = (reg_trie_state *)
3084             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
3085                                   sizeof(reg_trie_state) );
3086         next_alloc = trie->uniquecharcount + 1;
3087
3088
3089         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3090
3091             regnode *noper   = NEXTOPER( cur );
3092
3093             U32 state        = 1;         /* required init */
3094
3095             U16 charid       = 0;         /* sanity init */
3096             U32 accept_state = 0;         /* sanity init */
3097
3098             U32 wordlen      = 0;         /* required init */
3099
3100             if (OP(noper) == NOTHING) {
3101                 regnode *noper_next= regnext(noper);
3102                 if (noper_next < tail)
3103                     noper= noper_next;
3104             }
3105
3106             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3107                 const U8 *uc= (U8*)STRING(noper);
3108                 const U8 *e= uc + STR_LEN(noper);
3109
3110                 for ( ; uc < e ; uc += len ) {
3111
3112                     TRIE_READ_CHAR;
3113
3114                     if ( uvc < 256 ) {
3115                         charid = trie->charmap[ uvc ];
3116                     } else {
3117                         SV* const * const svpp = hv_fetch( widecharmap,
3118                                                            (char*)&uvc,
3119                                                            sizeof( UV ),
3120                                                            0);
3121                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3122                     }
3123                     if ( charid ) {
3124                         charid--;
3125                         if ( !trie->trans[ state + charid ].next ) {
3126                             trie->trans[ state + charid ].next = next_alloc;
3127                             trie->trans[ state ].check++;
3128                             prev_states[TRIE_NODENUM(next_alloc)]
3129                                     = TRIE_NODENUM(state);
3130                             next_alloc += trie->uniquecharcount;
3131                         }
3132                         state = trie->trans[ state + charid ].next;
3133                     } else {
3134                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3135                     }
3136                     /* charid is now 0 if we dont know the char read, or
3137                      * nonzero if we do */
3138                 }
3139             }
3140             accept_state = TRIE_NODENUM( state );
3141             TRIE_HANDLE_WORD(accept_state);
3142
3143         } /* end second pass */
3144
3145         /* and now dump it out before we compress it */
3146         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3147                                                           revcharmap,
3148                                                           next_alloc, depth+1));
3149
3150         {
3151         /*
3152            * Inplace compress the table.*
3153
3154            For sparse data sets the table constructed by the trie algorithm will
3155            be mostly 0/FAIL transitions or to put it another way mostly empty.
3156            (Note that leaf nodes will not contain any transitions.)
3157
3158            This algorithm compresses the tables by eliminating most such
3159            transitions, at the cost of a modest bit of extra work during lookup:
3160
3161            - Each states[] entry contains a .base field which indicates the
3162            index in the state[] array wheres its transition data is stored.
3163
3164            - If .base is 0 there are no valid transitions from that node.
3165
3166            - If .base is nonzero then charid is added to it to find an entry in
3167            the trans array.
3168
3169            -If trans[states[state].base+charid].check!=state then the
3170            transition is taken to be a 0/Fail transition. Thus if there are fail
3171            transitions at the front of the node then the .base offset will point
3172            somewhere inside the previous nodes data (or maybe even into a node
3173            even earlier), but the .check field determines if the transition is
3174            valid.
3175
3176            XXX - wrong maybe?
3177            The following process inplace converts the table to the compressed
3178            table: We first do not compress the root node 1,and mark all its
3179            .check pointers as 1 and set its .base pointer as 1 as well. This
3180            allows us to do a DFA construction from the compressed table later,
3181            and ensures that any .base pointers we calculate later are greater
3182            than 0.
3183
3184            - We set 'pos' to indicate the first entry of the second node.
3185
3186            - We then iterate over the columns of the node, finding the first and
3187            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3188            and set the .check pointers accordingly, and advance pos
3189            appropriately and repreat for the next node. Note that when we copy
3190            the next pointers we have to convert them from the original
3191            NODEIDX form to NODENUM form as the former is not valid post
3192            compression.
3193
3194            - If a node has no transitions used we mark its base as 0 and do not
3195            advance the pos pointer.
3196
3197            - If a node only has one transition we use a second pointer into the
3198            structure to fill in allocated fail transitions from other states.
3199            This pointer is independent of the main pointer and scans forward
3200            looking for null transitions that are allocated to a state. When it
3201            finds one it writes the single transition into the "hole".  If the
3202            pointer doesnt find one the single transition is appended as normal.
3203
3204            - Once compressed we can Renew/realloc the structures to release the
3205            excess space.
3206
3207            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3208            specifically Fig 3.47 and the associated pseudocode.
3209
3210            demq
3211         */
3212         const U32 laststate = TRIE_NODENUM( next_alloc );
3213         U32 state, charid;
3214         U32 pos = 0, zp=0;
3215         trie->statecount = laststate;
3216
3217         for ( state = 1 ; state < laststate ; state++ ) {
3218             U8 flag = 0;
3219             const U32 stateidx = TRIE_NODEIDX( state );
3220             const U32 o_used = trie->trans[ stateidx ].check;
3221             U32 used = trie->trans[ stateidx ].check;
3222             trie->trans[ stateidx ].check = 0;
3223
3224             for ( charid = 0;
3225                   used && charid < trie->uniquecharcount;
3226                   charid++ )
3227             {
3228                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3229                     if ( trie->trans[ stateidx + charid ].next ) {
3230                         if (o_used == 1) {
3231                             for ( ; zp < pos ; zp++ ) {
3232                                 if ( ! trie->trans[ zp ].next ) {
3233                                     break;
3234                                 }
3235                             }
3236                             trie->states[ state ].trans.base
3237                                                     = zp
3238                                                       + trie->uniquecharcount
3239                                                       - charid ;
3240                             trie->trans[ zp ].next
3241                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3242                                                              + charid ].next );
3243                             trie->trans[ zp ].check = state;
3244                             if ( ++zp > pos ) pos = zp;
3245                             break;
3246                         }
3247                         used--;
3248                     }
3249                     if ( !flag ) {
3250                         flag = 1;
3251                         trie->states[ state ].trans.base
3252                                        = pos + trie->uniquecharcount - charid ;
3253                     }
3254                     trie->trans[ pos ].next
3255                         = SAFE_TRIE_NODENUM(
3256                                        trie->trans[ stateidx + charid ].next );
3257                     trie->trans[ pos ].check = state;
3258                     pos++;
3259                 }
3260             }
3261         }
3262         trie->lasttrans = pos + 1;
3263         trie->states = (reg_trie_state *)
3264             PerlMemShared_realloc( trie->states, laststate
3265                                    * sizeof(reg_trie_state) );
3266         DEBUG_TRIE_COMPILE_MORE_r(
3267             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3268                 depth+1,
3269                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3270                        + 1 ),
3271                 (IV)next_alloc,
3272                 (IV)pos,
3273                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3274             );
3275
3276         } /* end table compress */
3277     }
3278     DEBUG_TRIE_COMPILE_MORE_r(
3279             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3280                 depth+1,
3281                 (UV)trie->statecount,
3282                 (UV)trie->lasttrans)
3283     );
3284     /* resize the trans array to remove unused space */
3285     trie->trans = (reg_trie_trans *)
3286         PerlMemShared_realloc( trie->trans, trie->lasttrans
3287                                * sizeof(reg_trie_trans) );
3288
3289     {   /* Modify the program and insert the new TRIE node */
3290         U8 nodetype =(U8)(flags & 0xFF);
3291         char *str=NULL;
3292
3293 #ifdef DEBUGGING
3294         regnode *optimize = NULL;
3295 #ifdef RE_TRACK_PATTERN_OFFSETS
3296
3297         U32 mjd_offset = 0;
3298         U32 mjd_nodelen = 0;
3299 #endif /* RE_TRACK_PATTERN_OFFSETS */
3300 #endif /* DEBUGGING */
3301         /*
3302            This means we convert either the first branch or the first Exact,
3303            depending on whether the thing following (in 'last') is a branch
3304            or not and whther first is the startbranch (ie is it a sub part of
3305            the alternation or is it the whole thing.)
3306            Assuming its a sub part we convert the EXACT otherwise we convert
3307            the whole branch sequence, including the first.
3308          */
3309         /* Find the node we are going to overwrite */
3310         if ( first != startbranch || OP( last ) == BRANCH ) {
3311             /* branch sub-chain */
3312             NEXT_OFF( first ) = (U16)(last - first);
3313 #ifdef RE_TRACK_PATTERN_OFFSETS
3314             DEBUG_r({
3315                 mjd_offset= Node_Offset((convert));
3316                 mjd_nodelen= Node_Length((convert));
3317             });
3318 #endif
3319             /* whole branch chain */
3320         }
3321 #ifdef RE_TRACK_PATTERN_OFFSETS
3322         else {
3323             DEBUG_r({
3324                 const  regnode *nop = NEXTOPER( convert );
3325                 mjd_offset= Node_Offset((nop));
3326                 mjd_nodelen= Node_Length((nop));
3327             });
3328         }
3329         DEBUG_OPTIMISE_r(
3330             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3331                 depth+1,
3332                 (UV)mjd_offset, (UV)mjd_nodelen)
3333         );
3334 #endif
3335         /* But first we check to see if there is a common prefix we can
3336            split out as an EXACT and put in front of the TRIE node.  */
3337         trie->startstate= 1;
3338         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3339             /* we want to find the first state that has more than
3340              * one transition, if that state is not the first state
3341              * then we have a common prefix which we can remove.
3342              */
3343             U32 state;
3344             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3345                 U32 ofs = 0;
3346                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3347                                        transition, -1 means none */
3348                 U32 count = 0;
3349                 const U32 base = trie->states[ state ].trans.base;
3350
3351                 /* does this state terminate an alternation? */
3352                 if ( trie->states[state].wordnum )
3353                         count = 1;
3354
3355                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3356                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3357                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3358                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3359                     {
3360                         if ( ++count > 1 ) {
3361                             /* we have more than one transition */
3362                             SV **tmp;
3363                             U8 *ch;
3364                             /* if this is the first state there is no common prefix
3365                              * to extract, so we can exit */
3366                             if ( state == 1 ) break;
3367                             tmp = av_fetch( revcharmap, ofs, 0);
3368                             ch = (U8*)SvPV_nolen_const( *tmp );
3369
3370                             /* if we are on count 2 then we need to initialize the
3371                              * bitmap, and store the previous char if there was one
3372                              * in it*/
3373                             if ( count == 2 ) {
3374                                 /* clear the bitmap */
3375                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3376                                 DEBUG_OPTIMISE_r(
3377                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3378                                         depth+1,
3379                                         (UV)state));
3380                                 if (first_ofs >= 0) {
3381                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3382                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3383
3384                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3385                                     DEBUG_OPTIMISE_r(
3386                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3387                                     );
3388                                 }
3389                             }
3390                             /* store the current firstchar in the bitmap */
3391                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3392                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3393                         }
3394                         first_ofs = ofs;
3395                     }
3396                 }
3397                 if ( count == 1 ) {
3398                     /* This state has only one transition, its transition is part
3399                      * of a common prefix - we need to concatenate the char it
3400                      * represents to what we have so far. */
3401                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3402                     STRLEN len;
3403                     char *ch = SvPV( *tmp, len );
3404                     DEBUG_OPTIMISE_r({
3405                         SV *sv=sv_newmortal();
3406                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3407                             depth+1,
3408                             (UV)state, (UV)first_ofs,
3409                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3410                                 PL_colors[0], PL_colors[1],
3411                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3412                                 PERL_PV_ESCAPE_FIRSTCHAR
3413                             )
3414                         );
3415                     });
3416                     if ( state==1 ) {
3417                         OP( convert ) = nodetype;
3418                         str=STRING(convert);
3419                         STR_LEN(convert)=0;
3420                     }
3421                     STR_LEN(convert) += len;
3422                     while (len--)
3423                         *str++ = *ch++;
3424                 } else {
3425 #ifdef DEBUGGING
3426                     if (state>1)
3427                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3428 #endif
3429                     break;
3430                 }
3431             }
3432             trie->prefixlen = (state-1);
3433             if (str) {
3434                 regnode *n = convert+NODE_SZ_STR(convert);
3435                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3436                 trie->startstate = state;
3437                 trie->minlen -= (state - 1);
3438                 trie->maxlen -= (state - 1);
3439 #ifdef DEBUGGING
3440                /* At least the UNICOS C compiler choked on this
3441                 * being argument to DEBUG_r(), so let's just have
3442                 * it right here. */
3443                if (
3444 #ifdef PERL_EXT_RE_BUILD
3445                    1
3446 #else
3447                    DEBUG_r_TEST
3448 #endif
3449                    ) {
3450                    regnode *fix = convert;
3451                    U32 word = trie->wordcount;
3452                    mjd_nodelen++;
3453                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3454                    while( ++fix < n ) {
3455                        Set_Node_Offset_Length(fix, 0, 0);
3456                    }
3457                    while (word--) {
3458                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3459                        if (tmp) {
3460                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3461                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3462                            else
3463                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3464                        }
3465                    }
3466                }
3467 #endif
3468                 if (trie->maxlen) {
3469                     convert = n;
3470                 } else {
3471                     NEXT_OFF(convert) = (U16)(tail - convert);
3472                     DEBUG_r(optimize= n);
3473                 }
3474             }
3475         }
3476         if (!jumper)
3477             jumper = last;
3478         if ( trie->maxlen ) {
3479             NEXT_OFF( convert ) = (U16)(tail - convert);
3480             ARG_SET( convert, data_slot );
3481             /* Store the offset to the first unabsorbed branch in
3482                jump[0], which is otherwise unused by the jump logic.
3483                We use this when dumping a trie and during optimisation. */
3484             if (trie->jump)
3485                 trie->jump[0] = (U16)(nextbranch - convert);
3486
3487             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3488              *   and there is a bitmap
3489              *   and the first "jump target" node we found leaves enough room
3490              * then convert the TRIE node into a TRIEC node, with the bitmap
3491              * embedded inline in the opcode - this is hypothetically faster.
3492              */
3493             if ( !trie->states[trie->startstate].wordnum
3494                  && trie->bitmap
3495                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3496             {
3497                 OP( convert ) = TRIEC;
3498                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3499                 PerlMemShared_free(trie->bitmap);
3500                 trie->bitmap= NULL;
3501             } else
3502                 OP( convert ) = TRIE;
3503
3504             /* store the type in the flags */
3505             convert->flags = nodetype;
3506             DEBUG_r({
3507             optimize = convert
3508                       + NODE_STEP_REGNODE
3509                       + regarglen[ OP( convert ) ];
3510             });
3511             /* XXX We really should free up the resource in trie now,
3512                    as we won't use them - (which resources?) dmq */
3513         }
3514         /* needed for dumping*/
3515         DEBUG_r(if (optimize) {
3516             regnode *opt = convert;
3517
3518             while ( ++opt < optimize) {
3519                 Set_Node_Offset_Length(opt,0,0);
3520             }
3521             /*
3522                 Try to clean up some of the debris left after the
3523                 optimisation.
3524              */
3525             while( optimize < jumper ) {
3526                 mjd_nodelen += Node_Length((optimize));
3527                 OP( optimize ) = OPTIMIZED;
3528                 Set_Node_Offset_Length(optimize,0,0);
3529                 optimize++;
3530             }
3531             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3532         });
3533     } /* end node insert */
3534
3535     /*  Finish populating the prev field of the wordinfo array.  Walk back
3536      *  from each accept state until we find another accept state, and if
3537      *  so, point the first word's .prev field at the second word. If the
3538      *  second already has a .prev field set, stop now. This will be the
3539      *  case either if we've already processed that word's accept state,
3540      *  or that state had multiple words, and the overspill words were
3541      *  already linked up earlier.
3542      */
3543     {
3544         U16 word;
3545         U32 state;
3546         U16 prev;
3547
3548         for (word=1; word <= trie->wordcount; word++) {
3549             prev = 0;
3550             if (trie->wordinfo[word].prev)
3551                 continue;
3552             state = trie->wordinfo[word].accept;
3553             while (state) {
3554                 state = prev_states[state];
3555                 if (!state)
3556                     break;
3557                 prev = trie->states[state].wordnum;
3558                 if (prev)
3559                     break;
3560             }
3561             trie->wordinfo[word].prev = prev;
3562         }
3563         Safefree(prev_states);
3564     }
3565
3566
3567     /* and now dump out the compressed format */
3568     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3569
3570     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3571 #ifdef DEBUGGING
3572     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3573     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3574 #else
3575     SvREFCNT_dec_NN(revcharmap);
3576 #endif
3577     return trie->jump
3578            ? MADE_JUMP_TRIE
3579            : trie->startstate>1
3580              ? MADE_EXACT_TRIE
3581              : MADE_TRIE;
3582 }
3583
3584 STATIC regnode *
3585 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3586 {
3587 /* The Trie is constructed and compressed now so we can build a fail array if
3588  * it's needed
3589
3590    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3591    3.32 in the
3592    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3593    Ullman 1985/88
3594    ISBN 0-201-10088-6
3595
3596    We find the fail state for each state in the trie, this state is the longest
3597    proper suffix of the current state's 'word' that is also a proper prefix of
3598    another word in our trie. State 1 represents the word '' and is thus the
3599    default fail state. This allows the DFA not to have to restart after its
3600    tried and failed a word at a given point, it simply continues as though it
3601    had been matching the other word in the first place.
3602    Consider
3603       'abcdgu'=~/abcdefg|cdgu/
3604    When we get to 'd' we are still matching the first word, we would encounter
3605    'g' which would fail, which would bring us to the state representing 'd' in
3606    the second word where we would try 'g' and succeed, proceeding to match
3607    'cdgu'.
3608  */
3609  /* add a fail transition */
3610     const U32 trie_offset = ARG(source);
3611     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3612     U32 *q;
3613     const U32 ucharcount = trie->uniquecharcount;
3614     const U32 numstates = trie->statecount;
3615     const U32 ubound = trie->lasttrans + ucharcount;
3616     U32 q_read = 0;
3617     U32 q_write = 0;
3618     U32 charid;
3619     U32 base = trie->states[ 1 ].trans.base;
3620     U32 *fail;
3621     reg_ac_data *aho;
3622     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3623     regnode *stclass;
3624     GET_RE_DEBUG_FLAGS_DECL;
3625
3626     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3627     PERL_UNUSED_CONTEXT;
3628 #ifndef DEBUGGING
3629     PERL_UNUSED_ARG(depth);
3630 #endif
3631
3632     if ( OP(source) == TRIE ) {
3633         struct regnode_1 *op = (struct regnode_1 *)
3634             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3635         StructCopy(source,op,struct regnode_1);
3636         stclass = (regnode *)op;
3637     } else {
3638         struct regnode_charclass *op = (struct regnode_charclass *)
3639             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3640         StructCopy(source,op,struct regnode_charclass);
3641         stclass = (regnode *)op;
3642     }
3643     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3644
3645     ARG_SET( stclass, data_slot );
3646     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3647     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3648     aho->trie=trie_offset;
3649     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3650     Copy( trie->states, aho->states, numstates, reg_trie_state );
3651     Newx( q, numstates, U32);
3652     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3653     aho->refcount = 1;
3654     fail = aho->fail;
3655     /* initialize fail[0..1] to be 1 so that we always have
3656        a valid final fail state */
3657     fail[ 0 ] = fail[ 1 ] = 1;
3658
3659     for ( charid = 0; charid < ucharcount ; charid++ ) {
3660         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3661         if ( newstate ) {
3662             q[ q_write ] = newstate;
3663             /* set to point at the root */
3664             fail[ q[ q_write++ ] ]=1;
3665         }
3666     }
3667     while ( q_read < q_write) {
3668         const U32 cur = q[ q_read++ % numstates ];
3669         base = trie->states[ cur ].trans.base;
3670
3671         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3672             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3673             if (ch_state) {
3674                 U32 fail_state = cur;
3675                 U32 fail_base;
3676                 do {
3677                     fail_state = fail[ fail_state ];
3678                     fail_base = aho->states[ fail_state ].trans.base;
3679                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3680
3681                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3682                 fail[ ch_state ] = fail_state;
3683                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3684                 {
3685                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3686                 }
3687                 q[ q_write++ % numstates] = ch_state;
3688             }
3689         }
3690     }
3691     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3692        when we fail in state 1, this allows us to use the
3693        charclass scan to find a valid start char. This is based on the principle
3694        that theres a good chance the string being searched contains lots of stuff
3695        that cant be a start char.
3696      */
3697     fail[ 0 ] = fail[ 1 ] = 0;
3698     DEBUG_TRIE_COMPILE_r({
3699         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3700                       depth, (UV)numstates
3701         );
3702         for( q_read=1; q_read<numstates; q_read++ ) {
3703             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3704         }
3705         Perl_re_printf( aTHX_  "\n");
3706     });
3707     Safefree(q);
3708     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3709     return stclass;
3710 }
3711
3712
3713 /* The below joins as many adjacent EXACTish nodes as possible into a single
3714  * one.  The regop may be changed if the node(s) contain certain sequences that
3715  * require special handling.  The joining is only done if:
3716  * 1) there is room in the current conglomerated node to entirely contain the
3717  *    next one.
3718  * 2) they are the exact same node type
3719  *
3720  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3721  * these get optimized out
3722  *
3723  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3724  * as possible, even if that means splitting an existing node so that its first
3725  * part is moved to the preceeding node.  This would maximise the efficiency of
3726  * memEQ during matching.
3727  *
3728  * If a node is to match under /i (folded), the number of characters it matches
3729  * can be different than its character length if it contains a multi-character
3730  * fold.  *min_subtract is set to the total delta number of characters of the
3731  * input nodes.
3732  *
3733  * And *unfolded_multi_char is set to indicate whether or not the node contains
3734  * an unfolded multi-char fold.  This happens when it won't be known until
3735  * runtime whether the fold is valid or not; namely
3736  *  1) for EXACTF nodes that contain LATIN SMALL LETTER SHARP S, as only if the
3737  *      target string being matched against turns out to be UTF-8 is that fold
3738  *      valid; or
3739  *  2) for EXACTFL nodes whose folding rules depend on the locale in force at
3740  *      runtime.
3741  * (Multi-char folds whose components are all above the Latin1 range are not
3742  * run-time locale dependent, and have already been folded by the time this
3743  * function is called.)
3744  *
3745  * This is as good a place as any to discuss the design of handling these
3746  * multi-character fold sequences.  It's been wrong in Perl for a very long
3747  * time.  There are three code points in Unicode whose multi-character folds
3748  * were long ago discovered to mess things up.  The previous designs for
3749  * dealing with these involved assigning a special node for them.  This
3750  * approach doesn't always work, as evidenced by this example:
3751  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3752  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3753  * would match just the \xDF, it won't be able to handle the case where a
3754  * successful match would have to cross the node's boundary.  The new approach
3755  * that hopefully generally solves the problem generates an EXACTFU_SS node
3756  * that is "sss" in this case.
3757  *
3758  * It turns out that there are problems with all multi-character folds, and not
3759  * just these three.  Now the code is general, for all such cases.  The
3760  * approach taken is:
3761  * 1)   This routine examines each EXACTFish node that could contain multi-
3762  *      character folded sequences.  Since a single character can fold into
3763  *      such a sequence, the minimum match length for this node is less than
3764  *      the number of characters in the node.  This routine returns in
3765  *      *min_subtract how many characters to subtract from the the actual
3766  *      length of the string to get a real minimum match length; it is 0 if
3767  *      there are no multi-char foldeds.  This delta is used by the caller to
3768  *      adjust the min length of the match, and the delta between min and max,
3769  *      so that the optimizer doesn't reject these possibilities based on size
3770  *      constraints.
3771  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3772  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3773  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3774  *      there is a possible fold length change.  That means that a regular
3775  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3776  *      with length changes, and so can be processed faster.  regexec.c takes
3777  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3778  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3779  *      known until runtime).  This saves effort in regex matching.  However,
3780  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3781  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3782  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3783  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3784  *      possibilities for the non-UTF8 patterns are quite simple, except for
3785  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3786  *      members of a fold-pair, and arrays are set up for all of them so that
3787  *      the other member of the pair can be found quickly.  Code elsewhere in
3788  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3789  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3790  *      described in the next item.
3791  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3792  *      validity of the fold won't be known until runtime, and so must remain
3793  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFAA
3794  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3795  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3796  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3797  *      The reason this is a problem is that the optimizer part of regexec.c
3798  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3799  *      that a character in the pattern corresponds to at most a single
3800  *      character in the target string.  (And I do mean character, and not byte
3801  *      here, unlike other parts of the documentation that have never been
3802  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3803  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFAA
3804  *      nodes it can match "\x{17F}\x{17F}".  These, along with other ones in
3805  *      EXACTFL nodes, violate the assumption, and they are the only instances
3806  *      where it is violated.  I'm reluctant to try to change the assumption,
3807  *      as the code involved is impenetrable to me (khw), so instead the code
3808  *      here punts.  This routine examines EXACTFL nodes, and (when the pattern
3809  *      isn't UTF-8) EXACTF and EXACTFAA for such unfolded folds, and returns a
3810  *      boolean indicating whether or not the node contains such a fold.  When
3811  *      it is true, the caller sets a flag that later causes the optimizer in
3812  *      this file to not set values for the floating and fixed string lengths,
3813  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3814  *      assumption.  Thus, there is no optimization based on string lengths for
3815  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3816  *      EXACTF and EXACTFAA nodes that contain the sharp s.  (The reason the
3817  *      assumption is wrong only in these cases is that all other non-UTF-8
3818  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3819  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3820  *      EXACTF nodes because we don't know at compile time if it actually
3821  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3822  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3823  *      always matches; and EXACTFAA where it never does.  In an EXACTFAA node
3824  *      in a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3825  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3826  *      string would require the pattern to be forced into UTF-8, the overhead
3827  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3828  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3829  *      locale.)
3830  *
3831  *      Similarly, the code that generates tries doesn't currently handle
3832  *      not-already-folded multi-char folds, and it looks like a pain to change
3833  *      that.  Therefore, trie generation of EXACTFAA nodes with the sharp s
3834  *      doesn't work.  Instead, such an EXACTFAA is turned into a new regnode,
3835  *      EXACTFAA_NO_TRIE, which the trie code knows not to handle.  Most people
3836  *      using /iaa matching will be doing so almost entirely with ASCII
3837  *      strings, so this should rarely be encountered in practice */
3838
3839 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3840     if (PL_regkind[OP(scan)] == EXACT) \
3841         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3842
3843 STATIC U32
3844 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3845                    UV *min_subtract, bool *unfolded_multi_char,
3846                    U32 flags,regnode *val, U32 depth)
3847 {
3848     /* Merge several consecutive EXACTish nodes into one. */
3849     regnode *n = regnext(scan);
3850     U32 stringok = 1;
3851     regnode *next = scan + NODE_SZ_STR(scan);
3852     U32 merged = 0;
3853     U32 stopnow = 0;
3854 #ifdef DEBUGGING
3855     regnode *stop = scan;
3856     GET_RE_DEBUG_FLAGS_DECL;
3857 #else
3858     PERL_UNUSED_ARG(depth);
3859 #endif
3860
3861     PERL_ARGS_ASSERT_JOIN_EXACT;
3862 #ifndef EXPERIMENTAL_INPLACESCAN
3863     PERL_UNUSED_ARG(flags);
3864     PERL_UNUSED_ARG(val);
3865 #endif
3866     DEBUG_PEEP("join", scan, depth, 0);
3867
3868     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3869      * EXACT ones that are mergeable to the current one. */
3870     while (n
3871            && (PL_regkind[OP(n)] == NOTHING
3872                || (stringok && OP(n) == OP(scan)))
3873            && NEXT_OFF(n)
3874            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3875     {
3876
3877         if (OP(n) == TAIL || n > next)
3878             stringok = 0;
3879         if (PL_regkind[OP(n)] == NOTHING) {
3880             DEBUG_PEEP("skip:", n, depth, 0);
3881             NEXT_OFF(scan) += NEXT_OFF(n);
3882             next = n + NODE_STEP_REGNODE;
3883 #ifdef DEBUGGING
3884             if (stringok)
3885                 stop = n;
3886 #endif
3887             n = regnext(n);
3888         }
3889         else if (stringok) {
3890             const unsigned int oldl = STR_LEN(scan);
3891             regnode * const nnext = regnext(n);
3892
3893             /* XXX I (khw) kind of doubt that this works on platforms (should
3894              * Perl ever run on one) where U8_MAX is above 255 because of lots
3895              * of other assumptions */
3896             /* Don't join if the sum can't fit into a single node */
3897             if (oldl + STR_LEN(n) > U8_MAX)
3898                 break;
3899
3900             DEBUG_PEEP("merg", n, depth, 0);
3901             merged++;
3902
3903             NEXT_OFF(scan) += NEXT_OFF(n);
3904             STR_LEN(scan) += STR_LEN(n);
3905             next = n + NODE_SZ_STR(n);
3906             /* Now we can overwrite *n : */
3907             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3908 #ifdef DEBUGGING
3909             stop = next - 1;
3910 #endif
3911             n = nnext;
3912             if (stopnow) break;
3913         }
3914
3915 #ifdef EXPERIMENTAL_INPLACESCAN
3916         if (flags && !NEXT_OFF(n)) {
3917             DEBUG_PEEP("atch", val, depth, 0);
3918             if (reg_off_by_arg[OP(n)]) {
3919                 ARG_SET(n, val - n);
3920             }
3921             else {
3922                 NEXT_OFF(n) = val - n;
3923             }
3924             stopnow = 1;
3925         }
3926 #endif
3927     }
3928
3929     *min_subtract = 0;
3930     *unfolded_multi_char = FALSE;
3931
3932     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3933      * can now analyze for sequences of problematic code points.  (Prior to
3934      * this final joining, sequences could have been split over boundaries, and
3935      * hence missed).  The sequences only happen in folding, hence for any
3936      * non-EXACT EXACTish node */
3937     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3938         U8* s0 = (U8*) STRING(scan);
3939         U8* s = s0;
3940         U8* s_end = s0 + STR_LEN(scan);
3941
3942         int total_count_delta = 0;  /* Total delta number of characters that
3943                                        multi-char folds expand to */
3944
3945         /* One pass is made over the node's string looking for all the
3946          * possibilities.  To avoid some tests in the loop, there are two main
3947          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3948          * non-UTF-8 */
3949         if (UTF) {
3950             U8* folded = NULL;
3951
3952             if (OP(scan) == EXACTFL) {
3953                 U8 *d;
3954
3955                 /* An EXACTFL node would already have been changed to another
3956                  * node type unless there is at least one character in it that
3957                  * is problematic; likely a character whose fold definition
3958                  * won't be known until runtime, and so has yet to be folded.
3959                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3960                  * to handle the UTF-8 case, we need to create a temporary
3961                  * folded copy using UTF-8 locale rules in order to analyze it.
3962                  * This is because our macros that look to see if a sequence is
3963                  * a multi-char fold assume everything is folded (otherwise the
3964                  * tests in those macros would be too complicated and slow).
3965                  * Note that here, the non-problematic folds will have already
3966                  * been done, so we can just copy such characters.  We actually
3967                  * don't completely fold the EXACTFL string.  We skip the
3968                  * unfolded multi-char folds, as that would just create work
3969                  * below to figure out the size they already are */
3970
3971                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3972                 d = folded;
3973                 while (s < s_end) {
3974                     STRLEN s_len = UTF8SKIP(s);
3975                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3976                         Copy(s, d, s_len, U8);
3977                         d += s_len;
3978                     }
3979                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3980                         *unfolded_multi_char = TRUE;
3981                         Copy(s, d, s_len, U8);
3982                         d += s_len;
3983                     }
3984                     else if (isASCII(*s)) {
3985                         *(d++) = toFOLD(*s);
3986                     }
3987                     else {
3988                         STRLEN len;
3989                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
3990                         d += len;
3991                     }
3992                     s += s_len;
3993                 }
3994
3995                 /* Point the remainder of the routine to look at our temporary
3996                  * folded copy */
3997                 s = folded;
3998                 s_end = d;
3999             } /* End of creating folded copy of EXACTFL string */
4000
4001             /* Examine the string for a multi-character fold sequence.  UTF-8
4002              * patterns have all characters pre-folded by the time this code is
4003              * executed */
4004             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
4005                                      length sequence we are looking for is 2 */
4006             {
4007                 int count = 0;  /* How many characters in a multi-char fold */
4008                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
4009                 if (! len) {    /* Not a multi-char fold: get next char */
4010                     s += UTF8SKIP(s);
4011                     continue;
4012                 }
4013
4014                 /* Nodes with 'ss' require special handling, except for
4015                  * EXACTFAA-ish for which there is no multi-char fold to this */
4016                 if (len == 2 && *s == 's' && *(s+1) == 's'
4017                     && OP(scan) != EXACTFAA
4018                     && OP(scan) != EXACTFAA_NO_TRIE)
4019                 {
4020                     count = 2;
4021                     if (OP(scan) != EXACTFL) {
4022                         OP(scan) = EXACTFU_SS;
4023                     }
4024                     s += 2;
4025                 }
4026                 else { /* Here is a generic multi-char fold. */
4027                     U8* multi_end  = s + len;
4028
4029                     /* Count how many characters are in it.  In the case of
4030                      * /aa, no folds which contain ASCII code points are
4031                      * allowed, so check for those, and skip if found. */
4032                     if (OP(scan) != EXACTFAA && OP(scan) != EXACTFAA_NO_TRIE) {
4033                         count = utf8_length(s, multi_end);
4034                         s = multi_end;
4035                     }
4036                     else {
4037                         while (s < multi_end) {
4038                             if (isASCII(*s)) {
4039                                 s++;
4040                                 goto next_iteration;
4041                             }
4042                             else {
4043                                 s += UTF8SKIP(s);
4044                             }
4045                             count++;
4046                         }
4047                     }
4048                 }
4049
4050                 /* The delta is how long the sequence is minus 1 (1 is how long
4051                  * the character that folds to the sequence is) */
4052                 total_count_delta += count - 1;
4053               next_iteration: ;
4054             }
4055
4056             /* We created a temporary folded copy of the string in EXACTFL
4057              * nodes.  Therefore we need to be sure it doesn't go below zero,
4058              * as the real string could be shorter */
4059             if (OP(scan) == EXACTFL) {
4060                 int total_chars = utf8_length((U8*) STRING(scan),
4061                                            (U8*) STRING(scan) + STR_LEN(scan));
4062                 if (total_count_delta > total_chars) {
4063                     total_count_delta = total_chars;
4064                 }
4065             }
4066
4067             *min_subtract += total_count_delta;
4068             Safefree(folded);
4069         }
4070         else if (OP(scan) == EXACTFAA) {
4071
4072             /* Non-UTF-8 pattern, EXACTFAA node.  There can't be a multi-char
4073              * fold to the ASCII range (and there are no existing ones in the
4074              * upper latin1 range).  But, as outlined in the comments preceding
4075              * this function, we need to flag any occurrences of the sharp s.
4076              * This character forbids trie formation (because of added
4077              * complexity) */
4078 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4079    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4080                                       || UNICODE_DOT_DOT_VERSION > 0)
4081             while (s < s_end) {
4082                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4083                     OP(scan) = EXACTFAA_NO_TRIE;
4084                     *unfolded_multi_char = TRUE;
4085                     break;
4086                 }
4087                 s++;
4088             }
4089         }
4090         else {
4091
4092             /* Non-UTF-8 pattern, not EXACTFAA node.  Look for the multi-char
4093              * folds that are all Latin1.  As explained in the comments
4094              * preceding this function, we look also for the sharp s in EXACTF
4095              * and EXACTFL nodes; it can be in the final position.  Otherwise
4096              * we can stop looking 1 byte earlier because have to find at least
4097              * two characters for a multi-fold */
4098             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4099                               ? s_end
4100                               : s_end -1;
4101
4102             while (s < upper) {
4103                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4104                 if (! len) {    /* Not a multi-char fold. */
4105                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4106                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4107                     {
4108                         *unfolded_multi_char = TRUE;
4109                     }
4110                     s++;
4111                     continue;
4112                 }
4113
4114                 if (len == 2
4115                     && isALPHA_FOLD_EQ(*s, 's')
4116                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4117                 {
4118
4119                     /* EXACTF nodes need to know that the minimum length
4120                      * changed so that a sharp s in the string can match this
4121                      * ss in the pattern, but they remain EXACTF nodes, as they
4122                      * won't match this unless the target string is is UTF-8,
4123                      * which we don't know until runtime.  EXACTFL nodes can't
4124                      * transform into EXACTFU nodes */
4125                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4126                         OP(scan) = EXACTFU_SS;
4127                     }
4128                 }
4129
4130                 *min_subtract += len - 1;
4131                 s += len;
4132             }
4133 #endif
4134         }
4135     }
4136
4137 #ifdef DEBUGGING
4138     /* Allow dumping but overwriting the collection of skipped
4139      * ops and/or strings with fake optimized ops */
4140     n = scan + NODE_SZ_STR(scan);
4141     while (n <= stop) {
4142         OP(n) = OPTIMIZED;
4143         FLAGS(n) = 0;
4144         NEXT_OFF(n) = 0;
4145         n++;
4146     }
4147 #endif
4148     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl", scan, depth, 0);});
4149     return stopnow;
4150 }
4151
4152 /* REx optimizer.  Converts nodes into quicker variants "in place".
4153    Finds fixed substrings.  */
4154
4155 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4156    to the position after last scanned or to NULL. */
4157
4158 #define INIT_AND_WITHP \
4159     assert(!and_withp); \
4160     Newx(and_withp,1, regnode_ssc); \
4161     SAVEFREEPV(and_withp)
4162
4163
4164 static void
4165 S_unwind_scan_frames(pTHX_ const void *p)
4166 {
4167     scan_frame *f= (scan_frame *)p;
4168     do {
4169         scan_frame *n= f->next_frame;
4170         Safefree(f);
4171         f= n;
4172     } while (f);
4173 }
4174
4175 /* the return from this sub is the minimum length that could possibly match */
4176 STATIC SSize_t
4177 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4178                         SSize_t *minlenp, SSize_t *deltap,
4179                         regnode *last,
4180                         scan_data_t *data,
4181                         I32 stopparen,
4182                         U32 recursed_depth,
4183                         regnode_ssc *and_withp,
4184                         U32 flags, U32 depth)
4185                         /* scanp: Start here (read-write). */
4186                         /* deltap: Write maxlen-minlen here. */
4187                         /* last: Stop before this one. */
4188                         /* data: string data about the pattern */
4189                         /* stopparen: treat close N as END */
4190                         /* recursed: which subroutines have we recursed into */
4191                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4192 {
4193     /* There must be at least this number of characters to match */
4194     SSize_t min = 0;
4195     I32 pars = 0, code;
4196     regnode *scan = *scanp, *next;
4197     SSize_t delta = 0;
4198     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4199     int is_inf_internal = 0;            /* The studied chunk is infinite */
4200     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4201     scan_data_t data_fake;
4202     SV *re_trie_maxbuff = NULL;
4203     regnode *first_non_open = scan;
4204     SSize_t stopmin = SSize_t_MAX;
4205     scan_frame *frame = NULL;
4206     GET_RE_DEBUG_FLAGS_DECL;
4207
4208     PERL_ARGS_ASSERT_STUDY_CHUNK;
4209     RExC_study_started= 1;
4210
4211     Zero(&data_fake, 1, scan_data_t);
4212
4213     if ( depth == 0 ) {
4214         while (first_non_open && OP(first_non_open) == OPEN)
4215             first_non_open=regnext(first_non_open);
4216     }
4217
4218
4219   fake_study_recurse:
4220     DEBUG_r(
4221         RExC_study_chunk_recursed_count++;
4222     );
4223     DEBUG_OPTIMISE_MORE_r(
4224     {
4225         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4226             depth, (long)stopparen,
4227             (unsigned long)RExC_study_chunk_recursed_count,
4228             (unsigned long)depth, (unsigned long)recursed_depth,
4229             scan,
4230             last);
4231         if (recursed_depth) {
4232             U32 i;
4233             U32 j;
4234             for ( j = 0 ; j < recursed_depth ; j++ ) {
4235                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4236                     if (
4237                         PAREN_TEST(RExC_study_chunk_recursed +
4238                                    ( j * RExC_study_chunk_recursed_bytes), i )
4239                         && (
4240                             !j ||
4241                             !PAREN_TEST(RExC_study_chunk_recursed +
4242                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4243                         )
4244                     ) {
4245                         Perl_re_printf( aTHX_ " %d",(int)i);
4246                         break;
4247                     }
4248                 }
4249                 if ( j + 1 < recursed_depth ) {
4250                     Perl_re_printf( aTHX_  ",");
4251                 }
4252             }
4253         }
4254         Perl_re_printf( aTHX_ "\n");
4255     }
4256     );
4257     while ( scan && OP(scan) != END && scan < last ){
4258         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4259                                    node length to get a real minimum (because
4260                                    the folded version may be shorter) */
4261         bool unfolded_multi_char = FALSE;
4262         /* Peephole optimizer: */
4263         DEBUG_STUDYDATA("Peep", data, depth, is_inf);
4264         DEBUG_PEEP("Peep", scan, depth, flags);
4265
4266
4267         /* The reason we do this here is that we need to deal with things like
4268          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4269          * parsing code, as each (?:..) is handled by a different invocation of
4270          * reg() -- Yves
4271          */
4272         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4273
4274         /* Follow the next-chain of the current node and optimize
4275            away all the NOTHINGs from it.  */
4276         if (OP(scan) != CURLYX) {
4277             const int max = (reg_off_by_arg[OP(scan)]
4278                        ? I32_MAX
4279                        /* I32 may be smaller than U16 on CRAYs! */
4280                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4281             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4282             int noff;
4283             regnode *n = scan;
4284
4285             /* Skip NOTHING and LONGJMP. */
4286             while ((n = regnext(n))
4287                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4288                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4289                    && off + noff < max)
4290                 off += noff;
4291             if (reg_off_by_arg[OP(scan)])
4292                 ARG(scan) = off;
4293             else
4294                 NEXT_OFF(scan) = off;
4295         }
4296
4297         /* The principal pseudo-switch.  Cannot be a switch, since we
4298            look into several different things.  */
4299         if ( OP(scan) == DEFINEP ) {
4300             SSize_t minlen = 0;
4301             SSize_t deltanext = 0;
4302             SSize_t fake_last_close = 0;
4303             I32 f = SCF_IN_DEFINE;
4304
4305             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4306             scan = regnext(scan);
4307             assert( OP(scan) == IFTHEN );
4308             DEBUG_PEEP("expect IFTHEN", scan, depth, flags);
4309
4310             data_fake.last_closep= &fake_last_close;
4311             minlen = *minlenp;
4312             next = regnext(scan);
4313             scan = NEXTOPER(NEXTOPER(scan));
4314             DEBUG_PEEP("scan", scan, depth, flags);
4315             DEBUG_PEEP("next", next, depth, flags);
4316
4317             /* we suppose the run is continuous, last=next...
4318              * NOTE we dont use the return here! */
4319             /* DEFINEP study_chunk() recursion */
4320             (void)study_chunk(pRExC_state, &scan, &minlen,
4321                               &deltanext, next, &data_fake, stopparen,
4322                               recursed_depth, NULL, f, depth+1);
4323
4324             scan = next;
4325         } else
4326         if (
4327             OP(scan) == BRANCH  ||
4328             OP(scan) == BRANCHJ ||
4329             OP(scan) == IFTHEN
4330         ) {
4331             next = regnext(scan);
4332             code = OP(scan);
4333
4334             /* The op(next)==code check below is to see if we
4335              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4336              * IFTHEN is special as it might not appear in pairs.
4337              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4338              * we dont handle it cleanly. */
4339             if (OP(next) == code || code == IFTHEN) {
4340                 /* NOTE - There is similar code to this block below for
4341                  * handling TRIE nodes on a re-study.  If you change stuff here
4342                  * check there too. */
4343                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4344                 regnode_ssc accum;
4345                 regnode * const startbranch=scan;
4346
4347                 if (flags & SCF_DO_SUBSTR) {
4348                     /* Cannot merge strings after this. */
4349                     scan_commit(pRExC_state, data, minlenp, is_inf);
4350                 }
4351
4352                 if (flags & SCF_DO_STCLASS)
4353                     ssc_init_zero(pRExC_state, &accum);
4354
4355                 while (OP(scan) == code) {
4356                     SSize_t deltanext, minnext, fake;
4357                     I32 f = 0;
4358                     regnode_ssc this_class;
4359
4360                     DEBUG_PEEP("Branch", scan, depth, flags);
4361
4362                     num++;
4363                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4364                     if (data) {
4365                         data_fake.whilem_c = data->whilem_c;
4366                         data_fake.last_closep = data->last_closep;
4367                     }
4368                     else
4369                         data_fake.last_closep = &fake;
4370
4371                     data_fake.pos_delta = delta;
4372                     next = regnext(scan);
4373
4374                     scan = NEXTOPER(scan); /* everything */
4375                     if (code != BRANCH)    /* everything but BRANCH */
4376                         scan = NEXTOPER(scan);
4377
4378                     if (flags & SCF_DO_STCLASS) {
4379                         ssc_init(pRExC_state, &this_class);
4380                         data_fake.start_class = &this_class;
4381                         f = SCF_DO_STCLASS_AND;
4382                     }
4383                     if (flags & SCF_WHILEM_VISITED_POS)
4384                         f |= SCF_WHILEM_VISITED_POS;
4385
4386                     /* we suppose the run is continuous, last=next...*/
4387                     /* recurse study_chunk() for each BRANCH in an alternation */
4388                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4389                                       &deltanext, next, &data_fake, stopparen,
4390                                       recursed_depth, NULL, f,depth+1);
4391
4392                     if (min1 > minnext)
4393                         min1 = minnext;
4394                     if (deltanext == SSize_t_MAX) {
4395                         is_inf = is_inf_internal = 1;
4396                         max1 = SSize_t_MAX;
4397                     } else if (max1 < minnext + deltanext)
4398                         max1 = minnext + deltanext;
4399                     scan = next;
4400                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4401                         pars++;
4402                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4403                         if ( stopmin > minnext)
4404                             stopmin = min + min1;
4405                         flags &= ~SCF_DO_SUBSTR;
4406                         if (data)
4407                             data->flags |= SCF_SEEN_ACCEPT;
4408                     }
4409                     if (data) {
4410                         if (data_fake.flags & SF_HAS_EVAL)
4411                             data->flags |= SF_HAS_EVAL;
4412                         data->whilem_c = data_fake.whilem_c;
4413                     }
4414                     if (flags & SCF_DO_STCLASS)
4415                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4416                 }
4417                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4418                     min1 = 0;
4419                 if (flags & SCF_DO_SUBSTR) {
4420                     data->pos_min += min1;
4421                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4422                         data->pos_delta = SSize_t_MAX;
4423                     else
4424                         data->pos_delta += max1 - min1;
4425                     if (max1 != min1 || is_inf)
4426                         data->cur_is_floating = 1;
4427                 }
4428                 min += min1;
4429                 if (delta == SSize_t_MAX
4430                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4431                     delta = SSize_t_MAX;
4432                 else
4433                     delta += max1 - min1;
4434                 if (flags & SCF_DO_STCLASS_OR) {
4435                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4436                     if (min1) {
4437                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4438                         flags &= ~SCF_DO_STCLASS;
4439                     }
4440                 }
4441                 else if (flags & SCF_DO_STCLASS_AND) {
4442                     if (min1) {
4443                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4444                         flags &= ~SCF_DO_STCLASS;
4445                     }
4446                     else {
4447                         /* Switch to OR mode: cache the old value of
4448                          * data->start_class */
4449                         INIT_AND_WITHP;
4450                         StructCopy(data->start_class, and_withp, regnode_ssc);
4451                         flags &= ~SCF_DO_STCLASS_AND;
4452                         StructCopy(&accum, data->start_class, regnode_ssc);
4453                         flags |= SCF_DO_STCLASS_OR;
4454                     }
4455                 }
4456
4457                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4458                         OP( startbranch ) == BRANCH )
4459                 {
4460                 /* demq.
4461
4462                    Assuming this was/is a branch we are dealing with: 'scan'
4463                    now points at the item that follows the branch sequence,
4464                    whatever it is. We now start at the beginning of the
4465                    sequence and look for subsequences of
4466
4467                    BRANCH->EXACT=>x1
4468                    BRANCH->EXACT=>x2
4469                    tail
4470
4471                    which would be constructed from a pattern like
4472                    /A|LIST|OF|WORDS/
4473
4474                    If we can find such a subsequence we need to turn the first
4475                    element into a trie and then add the subsequent branch exact
4476                    strings to the trie.
4477
4478                    We have two cases
4479
4480                      1. patterns where the whole set of branches can be
4481                         converted.
4482
4483                      2. patterns where only a subset can be converted.
4484
4485                    In case 1 we can replace the whole set with a single regop
4486                    for the trie. In case 2 we need to keep the start and end
4487                    branches so
4488
4489                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4490                      becomes BRANCH TRIE; BRANCH X;
4491
4492                   There is an additional case, that being where there is a
4493                   common prefix, which gets split out into an EXACT like node
4494                   preceding the TRIE node.
4495
4496                   If x(1..n)==tail then we can do a simple trie, if not we make
4497                   a "jump" trie, such that when we match the appropriate word
4498                   we "jump" to the appropriate tail node. Essentially we turn
4499                   a nested if into a case structure of sorts.
4500
4501                 */
4502
4503                     int made=0;
4504                     if (!re_trie_maxbuff) {
4505                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4506                         if (!SvIOK(re_trie_maxbuff))
4507                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4508                     }
4509                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4510                         regnode *cur;
4511                         regnode *first = (regnode *)NULL;
4512                         regnode *last = (regnode *)NULL;
4513                         regnode *tail = scan;
4514                         U8 trietype = 0;
4515                         U32 count=0;
4516
4517                         /* var tail is used because there may be a TAIL
4518                            regop in the way. Ie, the exacts will point to the
4519                            thing following the TAIL, but the last branch will
4520                            point at the TAIL. So we advance tail. If we
4521                            have nested (?:) we may have to move through several
4522                            tails.
4523                          */
4524
4525                         while ( OP( tail ) == TAIL ) {
4526                             /* this is the TAIL generated by (?:) */
4527                             tail = regnext( tail );
4528                         }
4529
4530
4531                         DEBUG_TRIE_COMPILE_r({
4532                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4533                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4534                               depth+1,
4535                               "Looking for TRIE'able sequences. Tail node is ",
4536                               (UV)(tail - RExC_emit_start),
4537                               SvPV_nolen_const( RExC_mysv )
4538                             );
4539                         });
4540
4541                         /*
4542
4543                             Step through the branches
4544                                 cur represents each branch,
4545                                 noper is the first thing to be matched as part
4546                                       of that branch
4547                                 noper_next is the regnext() of that node.
4548
4549                             We normally handle a case like this
4550                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4551                             support building with NOJUMPTRIE, which restricts
4552                             the trie logic to structures like /FOO|BAR/.
4553
4554                             If noper is a trieable nodetype then the branch is
4555                             a possible optimization target. If we are building
4556                             under NOJUMPTRIE then we require that noper_next is
4557                             the same as scan (our current position in the regex
4558                             program).
4559
4560                             Once we have two or more consecutive such branches
4561                             we can create a trie of the EXACT's contents and
4562                             stitch it in place into the program.
4563
4564                             If the sequence represents all of the branches in
4565                             the alternation we replace the entire thing with a
4566                             single TRIE node.
4567
4568                             Otherwise when it is a subsequence we need to
4569                             stitch it in place and replace only the relevant
4570                             branches. This means the first branch has to remain
4571                             as it is used by the alternation logic, and its
4572                             next pointer, and needs to be repointed at the item
4573                             on the branch chain following the last branch we
4574                             have optimized away.
4575
4576                             This could be either a BRANCH, in which case the
4577                             subsequence is internal, or it could be the item
4578                             following the branch sequence in which case the
4579                             subsequence is at the end (which does not
4580                             necessarily mean the first node is the start of the
4581                             alternation).
4582
4583                             TRIE_TYPE(X) is a define which maps the optype to a
4584                             trietype.
4585
4586                                 optype          |  trietype
4587                                 ----------------+-----------
4588                                 NOTHING         | NOTHING
4589                                 EXACT           | EXACT
4590                                 EXACTFU         | EXACTFU
4591                                 EXACTFU_SS      | EXACTFU
4592                                 EXACTFAA         | EXACTFAA
4593                                 EXACTL          | EXACTL
4594                                 EXACTFLU8       | EXACTFLU8
4595
4596
4597                         */
4598 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4599                        ? NOTHING                                            \
4600                        : ( EXACT == (X) )                                   \
4601                          ? EXACT                                            \
4602                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4603                            ? EXACTFU                                        \
4604                            : ( EXACTFAA == (X) )                             \
4605                              ? EXACTFAA                                      \
4606                              : ( EXACTL == (X) )                            \
4607                                ? EXACTL                                     \
4608                                : ( EXACTFLU8 == (X) )                        \
4609                                  ? EXACTFLU8                                 \
4610                                  : 0 )
4611
4612                         /* dont use tail as the end marker for this traverse */
4613                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4614                             regnode * const noper = NEXTOPER( cur );
4615                             U8 noper_type = OP( noper );
4616                             U8 noper_trietype = TRIE_TYPE( noper_type );
4617 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4618                             regnode * const noper_next = regnext( noper );
4619                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4620                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4621 #endif
4622
4623                             DEBUG_TRIE_COMPILE_r({
4624                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4625                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4626                                    depth+1,
4627                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4628
4629                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4630                                 Perl_re_printf( aTHX_  " -> %d:%s",
4631                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4632
4633                                 if ( noper_next ) {
4634                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4635                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4636                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4637                                 }
4638                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4639                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4640                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4641                                 );
4642                             });
4643
4644                             /* Is noper a trieable nodetype that can be merged
4645                              * with the current trie (if there is one)? */
4646                             if ( noper_trietype
4647                                   &&
4648                                   (
4649                                         ( noper_trietype == NOTHING )
4650                                         || ( trietype == NOTHING )
4651                                         || ( trietype == noper_trietype )
4652                                   )
4653 #ifdef NOJUMPTRIE
4654                                   && noper_next >= tail
4655 #endif
4656                                   && count < U16_MAX)
4657                             {
4658                                 /* Handle mergable triable node Either we are
4659                                  * the first node in a new trieable sequence,
4660                                  * in which case we do some bookkeeping,
4661                                  * otherwise we update the end pointer. */
4662                                 if ( !first ) {
4663                                     first = cur;
4664                                     if ( noper_trietype == NOTHING ) {
4665 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4666                                         regnode * const noper_next = regnext( noper );
4667                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4668                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4669 #endif
4670
4671                                         if ( noper_next_trietype ) {
4672                                             trietype = noper_next_trietype;
4673                                         } else if (noper_next_type)  {
4674                                             /* a NOTHING regop is 1 regop wide.
4675                                              * We need at least two for a trie
4676                                              * so we can't merge this in */
4677                                             first = NULL;
4678                                         }
4679                                     } else {
4680                                         trietype = noper_trietype;
4681                                     }
4682                                 } else {
4683                                     if ( trietype == NOTHING )
4684                                         trietype = noper_trietype;
4685                                     last = cur;
4686                                 }
4687                                 if (first)
4688                                     count++;
4689                             } /* end handle mergable triable node */
4690                             else {
4691                                 /* handle unmergable node -
4692                                  * noper may either be a triable node which can
4693                                  * not be tried together with the current trie,
4694                                  * or a non triable node */
4695                                 if ( last ) {
4696                                     /* If last is set and trietype is not
4697                                      * NOTHING then we have found at least two
4698                                      * triable branch sequences in a row of a
4699                                      * similar trietype so we can turn them
4700                                      * into a trie. If/when we allow NOTHING to
4701                                      * start a trie sequence this condition
4702                                      * will be required, and it isn't expensive
4703                                      * so we leave it in for now. */
4704                                     if ( trietype && trietype != NOTHING )
4705                                         make_trie( pRExC_state,
4706                                                 startbranch, first, cur, tail,
4707                                                 count, trietype, depth+1 );
4708                                     last = NULL; /* note: we clear/update
4709                                                     first, trietype etc below,
4710                                                     so we dont do it here */
4711                                 }
4712                                 if ( noper_trietype
4713 #ifdef NOJUMPTRIE
4714                                      && noper_next >= tail
4715 #endif
4716                                 ){
4717                                     /* noper is triable, so we can start a new
4718                                      * trie sequence */
4719                                     count = 1;
4720                                     first = cur;
4721                                     trietype = noper_trietype;
4722                                 } else if (first) {
4723                                     /* if we already saw a first but the
4724                                      * current node is not triable then we have
4725                                      * to reset the first information. */
4726                                     count = 0;
4727                                     first = NULL;
4728                                     trietype = 0;
4729                                 }
4730                             } /* end handle unmergable node */
4731                         } /* loop over branches */
4732                         DEBUG_TRIE_COMPILE_r({
4733                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4734                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4735                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4736                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4737                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4738                                PL_reg_name[trietype]
4739                             );
4740
4741                         });
4742                         if ( last && trietype ) {
4743                             if ( trietype != NOTHING ) {
4744                                 /* the last branch of the sequence was part of
4745                                  * a trie, so we have to construct it here
4746                                  * outside of the loop */
4747                                 made= make_trie( pRExC_state, startbranch,
4748                                                  first, scan, tail, count,
4749                                                  trietype, depth+1 );
4750 #ifdef TRIE_STUDY_OPT
4751                                 if ( ((made == MADE_EXACT_TRIE &&
4752                                      startbranch == first)
4753                                      || ( first_non_open == first )) &&
4754                                      depth==0 ) {
4755                                     flags |= SCF_TRIE_RESTUDY;
4756                                     if ( startbranch == first
4757                                          && scan >= tail )
4758                                     {
4759                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4760                                     }
4761                                 }
4762 #endif
4763                             } else {
4764                                 /* at this point we know whatever we have is a
4765                                  * NOTHING sequence/branch AND if 'startbranch'
4766                                  * is 'first' then we can turn the whole thing
4767                                  * into a NOTHING
4768                                  */
4769                                 if ( startbranch == first ) {
4770                                     regnode *opt;
4771                                     /* the entire thing is a NOTHING sequence,
4772                                      * something like this: (?:|) So we can
4773                                      * turn it into a plain NOTHING op. */
4774                                     DEBUG_TRIE_COMPILE_r({
4775                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4776                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4777                                           depth+1,
4778                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4779
4780                                     });
4781                                     OP(startbranch)= NOTHING;
4782                                     NEXT_OFF(startbranch)= tail - startbranch;
4783                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4784                                         OP(opt)= OPTIMIZED;
4785                                 }
4786                             }
4787                         } /* end if ( last) */
4788                     } /* TRIE_MAXBUF is non zero */
4789
4790                 } /* do trie */
4791
4792             }
4793             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4794                 scan = NEXTOPER(NEXTOPER(scan));
4795             } else                      /* single branch is optimized. */
4796                 scan = NEXTOPER(scan);
4797             continue;
4798         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4799             I32 paren = 0;
4800             regnode *start = NULL;
4801             regnode *end = NULL;
4802             U32 my_recursed_depth= recursed_depth;
4803
4804             if (OP(scan) != SUSPEND) { /* GOSUB */
4805                 /* Do setup, note this code has side effects beyond
4806                  * the rest of this block. Specifically setting
4807                  * RExC_recurse[] must happen at least once during
4808                  * study_chunk(). */
4809                 paren = ARG(scan);
4810                 RExC_recurse[ARG2L(scan)] = scan;
4811                 start = RExC_open_parens[paren];
4812                 end   = RExC_close_parens[paren];
4813
4814                 /* NOTE we MUST always execute the above code, even
4815                  * if we do nothing with a GOSUB */
4816                 if (
4817                     ( flags & SCF_IN_DEFINE )
4818                     ||
4819                     (
4820                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4821                         &&
4822                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4823                     )
4824                 ) {
4825                     /* no need to do anything here if we are in a define. */
4826                     /* or we are after some kind of infinite construct
4827                      * so we can skip recursing into this item.
4828                      * Since it is infinite we will not change the maxlen
4829                      * or delta, and if we miss something that might raise
4830                      * the minlen it will merely pessimise a little.
4831                      *
4832                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4833                      * might result in a minlen of 1 and not of 4,
4834                      * but this doesn't make us mismatch, just try a bit
4835                      * harder than we should.
4836                      * */
4837                     scan= regnext(scan);
4838                     continue;
4839                 }
4840
4841                 if (
4842                     !recursed_depth
4843                     ||
4844                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4845                 ) {
4846                     /* it is quite possible that there are more efficient ways
4847                      * to do this. We maintain a bitmap per level of recursion
4848                      * of which patterns we have entered so we can detect if a
4849                      * pattern creates a possible infinite loop. When we
4850                      * recurse down a level we copy the previous levels bitmap
4851                      * down. When we are at recursion level 0 we zero the top
4852                      * level bitmap. It would be nice to implement a different
4853                      * more efficient way of doing this. In particular the top
4854                      * level bitmap may be unnecessary.
4855                      */
4856                     if (!recursed_depth) {
4857                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4858                     } else {
4859                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4860                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4861                              RExC_study_chunk_recursed_bytes, U8);
4862                     }
4863                     /* we havent recursed into this paren yet, so recurse into it */
4864                     DEBUG_STUDYDATA("gosub-set", data, depth, is_inf);
4865                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4866                     my_recursed_depth= recursed_depth + 1;
4867                 } else {
4868                     DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf);
4869                     /* some form of infinite recursion, assume infinite length
4870                      * */
4871                     if (flags & SCF_DO_SUBSTR) {
4872                         scan_commit(pRExC_state, data, minlenp, is_inf);
4873                         data->cur_is_floating = 1;
4874                     }
4875                     is_inf = is_inf_internal = 1;
4876                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4877                         ssc_anything(data->start_class);
4878                     flags &= ~SCF_DO_STCLASS;
4879
4880                     start= NULL; /* reset start so we dont recurse later on. */
4881                 }
4882             } else {
4883                 paren = stopparen;
4884                 start = scan + 2;
4885                 end = regnext(scan);
4886             }
4887             if (start) {
4888                 scan_frame *newframe;
4889                 assert(end);
4890                 if (!RExC_frame_last) {
4891                     Newxz(newframe, 1, scan_frame);
4892                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4893                     RExC_frame_head= newframe;
4894                     RExC_frame_count++;
4895                 } else if (!RExC_frame_last->next_frame) {
4896                     Newxz(newframe,1,scan_frame);
4897                     RExC_frame_last->next_frame= newframe;
4898                     newframe->prev_frame= RExC_frame_last;
4899                     RExC_frame_count++;
4900                 } else {
4901                     newframe= RExC_frame_last->next_frame;
4902                 }
4903                 RExC_frame_last= newframe;
4904
4905                 newframe->next_regnode = regnext(scan);
4906                 newframe->last_regnode = last;
4907                 newframe->stopparen = stopparen;
4908                 newframe->prev_recursed_depth = recursed_depth;
4909                 newframe->this_prev_frame= frame;
4910
4911                 DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
4912                 DEBUG_PEEP("fnew", scan, depth, flags);
4913
4914                 frame = newframe;
4915                 scan =  start;
4916                 stopparen = paren;
4917                 last = end;
4918                 depth = depth + 1;
4919                 recursed_depth= my_recursed_depth;
4920
4921                 continue;
4922             }
4923         }
4924         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4925             SSize_t l = STR_LEN(scan);
4926             UV uc;
4927             assert(l);
4928             if (UTF) {
4929                 const U8 * const s = (U8*)STRING(scan);
4930                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4931                 l = utf8_length(s, s + l);
4932             } else {
4933                 uc = *((U8*)STRING(scan));
4934             }
4935             min += l;
4936             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4937                 /* The code below prefers earlier match for fixed
4938                    offset, later match for variable offset.  */
4939                 if (data->last_end == -1) { /* Update the start info. */
4940                     data->last_start_min = data->pos_min;
4941                     data->last_start_max = is_inf
4942                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4943                 }
4944                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4945                 if (UTF)
4946                     SvUTF8_on(data->last_found);
4947                 {
4948                     SV * const sv = data->last_found;
4949                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4950                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4951                     if (mg && mg->mg_len >= 0)
4952                         mg->mg_len += utf8_length((U8*)STRING(scan),
4953                                               (U8*)STRING(scan)+STR_LEN(scan));
4954                 }
4955                 data->last_end = data->pos_min + l;
4956                 data->pos_min += l; /* As in the first entry. */
4957                 data->flags &= ~SF_BEFORE_EOL;
4958             }
4959
4960             /* ANDing the code point leaves at most it, and not in locale, and
4961              * can't match null string */
4962             if (flags & SCF_DO_STCLASS_AND) {
4963                 ssc_cp_and(data->start_class, uc);
4964                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4965                 ssc_clear_locale(data->start_class);
4966             }
4967             else if (flags & SCF_DO_STCLASS_OR) {
4968                 ssc_add_cp(data->start_class, uc);
4969                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4970
4971                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4972                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4973             }
4974             flags &= ~SCF_DO_STCLASS;
4975         }
4976         else if (PL_regkind[OP(scan)] == EXACT) {
4977             /* But OP != EXACT!, so is EXACTFish */
4978             SSize_t l = STR_LEN(scan);
4979             const U8 * s = (U8*)STRING(scan);
4980
4981             /* Search for fixed substrings supports EXACT only. */
4982             if (flags & SCF_DO_SUBSTR) {
4983                 assert(data);
4984                 scan_commit(pRExC_state, data, minlenp, is_inf);
4985             }
4986             if (UTF) {
4987                 l = utf8_length(s, s + l);
4988             }
4989             if (unfolded_multi_char) {
4990                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4991             }
4992             min += l - min_subtract;
4993             assert (min >= 0);
4994             delta += min_subtract;
4995             if (flags & SCF_DO_SUBSTR) {
4996                 data->pos_min += l - min_subtract;
4997                 if (data->pos_min < 0) {
4998                     data->pos_min = 0;
4999                 }
5000                 data->pos_delta += min_subtract;
5001                 if (min_subtract) {
5002                     data->cur_is_floating = 1; /* float */
5003                 }
5004             }
5005
5006             if (flags & SCF_DO_STCLASS) {
5007                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
5008
5009                 assert(EXACTF_invlist);
5010                 if (flags & SCF_DO_STCLASS_AND) {
5011                     if (OP(scan) != EXACTFL)
5012                         ssc_clear_locale(data->start_class);
5013                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5014                     ANYOF_POSIXL_ZERO(data->start_class);
5015                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
5016                 }
5017                 else {  /* SCF_DO_STCLASS_OR */
5018                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
5019                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5020
5021                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5022                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5023                 }
5024                 flags &= ~SCF_DO_STCLASS;
5025                 SvREFCNT_dec(EXACTF_invlist);
5026             }
5027         }
5028         else if (REGNODE_VARIES(OP(scan))) {
5029             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
5030             I32 fl = 0, f = flags;
5031             regnode * const oscan = scan;
5032             regnode_ssc this_class;
5033             regnode_ssc *oclass = NULL;
5034             I32 next_is_eval = 0;
5035
5036             switch (PL_regkind[OP(scan)]) {
5037             case WHILEM:                /* End of (?:...)* . */
5038                 scan = NEXTOPER(scan);
5039                 goto finish;
5040             case PLUS:
5041                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
5042                     next = NEXTOPER(scan);
5043                     if (OP(next) == EXACT
5044                         || OP(next) == EXACTL
5045                         || (flags & SCF_DO_STCLASS))
5046                     {
5047                         mincount = 1;
5048                         maxcount = REG_INFTY;
5049                         next = regnext(scan);
5050                         scan = NEXTOPER(scan);
5051                         goto do_curly;
5052                     }
5053                 }
5054                 if (flags & SCF_DO_SUBSTR)
5055                     data->pos_min++;
5056                 min++;
5057                 /* FALLTHROUGH */
5058             case STAR:
5059                 if (flags & SCF_DO_STCLASS) {
5060                     mincount = 0;
5061                     maxcount = REG_INFTY;
5062                     next = regnext(scan);
5063                     scan = NEXTOPER(scan);
5064                     goto do_curly;
5065                 }
5066                 if (flags & SCF_DO_SUBSTR) {
5067                     scan_commit(pRExC_state, data, minlenp, is_inf);
5068                     /* Cannot extend fixed substrings */
5069                     data->cur_is_floating = 1; /* float */
5070                 }
5071                 is_inf = is_inf_internal = 1;
5072                 scan = regnext(scan);
5073                 goto optimize_curly_tail;
5074             case CURLY:
5075                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
5076                     && (scan->flags == stopparen))
5077                 {
5078                     mincount = 1;
5079                     maxcount = 1;
5080                 } else {
5081                     mincount = ARG1(scan);
5082                     maxcount = ARG2(scan);
5083                 }
5084                 next = regnext(scan);
5085                 if (OP(scan) == CURLYX) {
5086                     I32 lp = (data ? *(data->last_closep) : 0);
5087                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5088                 }
5089                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5090                 next_is_eval = (OP(scan) == EVAL);
5091               do_curly:
5092                 if (flags & SCF_DO_SUBSTR) {
5093                     if (mincount == 0)
5094                         scan_commit(pRExC_state, data, minlenp, is_inf);
5095                     /* Cannot extend fixed substrings */
5096                     pos_before = data->pos_min;
5097                 }
5098                 if (data) {
5099                     fl = data->flags;
5100                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5101                     if (is_inf)
5102                         data->flags |= SF_IS_INF;
5103                 }
5104                 if (flags & SCF_DO_STCLASS) {
5105                     ssc_init(pRExC_state, &this_class);
5106                     oclass = data->start_class;
5107                     data->start_class = &this_class;
5108                     f |= SCF_DO_STCLASS_AND;
5109                     f &= ~SCF_DO_STCLASS_OR;
5110                 }
5111                 /* Exclude from super-linear cache processing any {n,m}
5112                    regops for which the combination of input pos and regex
5113                    pos is not enough information to determine if a match
5114                    will be possible.
5115
5116                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5117                    regex pos at the \s*, the prospects for a match depend not
5118                    only on the input position but also on how many (bar\s*)
5119                    repeats into the {4,8} we are. */
5120                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5121                     f &= ~SCF_WHILEM_VISITED_POS;
5122
5123                 /* This will finish on WHILEM, setting scan, or on NULL: */
5124                 /* recurse study_chunk() on loop bodies */
5125                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5126                                   last, data, stopparen, recursed_depth, NULL,
5127                                   (mincount == 0
5128                                    ? (f & ~SCF_DO_SUBSTR)
5129                                    : f)
5130                                   ,depth+1);
5131
5132                 if (flags & SCF_DO_STCLASS)
5133                     data->start_class = oclass;
5134                 if (mincount == 0 || minnext == 0) {
5135                     if (flags & SCF_DO_STCLASS_OR) {
5136                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5137                     }
5138                     else if (flags & SCF_DO_STCLASS_AND) {
5139                         /* Switch to OR mode: cache the old value of
5140                          * data->start_class */
5141                         INIT_AND_WITHP;
5142                         StructCopy(data->start_class, and_withp, regnode_ssc);
5143                         flags &= ~SCF_DO_STCLASS_AND;
5144                         StructCopy(&this_class, data->start_class, regnode_ssc);
5145                         flags |= SCF_DO_STCLASS_OR;
5146                         ANYOF_FLAGS(data->start_class)
5147                                                 |= SSC_MATCHES_EMPTY_STRING;
5148                     }
5149                 } else {                /* Non-zero len */
5150                     if (flags & SCF_DO_STCLASS_OR) {
5151                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5152                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5153                     }
5154                     else if (flags & SCF_DO_STCLASS_AND)
5155                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5156                     flags &= ~SCF_DO_STCLASS;
5157                 }
5158                 if (!scan)              /* It was not CURLYX, but CURLY. */
5159                     scan = next;
5160                 if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR)
5161                     /* ? quantifier ok, except for (?{ ... }) */
5162                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5163                     && (minnext == 0) && (deltanext == 0)
5164                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5165                     && maxcount <= REG_INFTY/3) /* Complement check for big
5166                                                    count */
5167                 {
5168                     /* Fatal warnings may leak the regexp without this: */
5169                     SAVEFREESV(RExC_rx_sv);
5170                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5171                         "Quantifier unexpected on zero-length expression "
5172                         "in regex m/%" UTF8f "/",
5173                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5174                                   RExC_precomp));
5175                     (void)ReREFCNT_inc(RExC_rx_sv);
5176                 }
5177
5178                 min += minnext * mincount;
5179                 is_inf_internal |= deltanext == SSize_t_MAX
5180                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5181                 is_inf |= is_inf_internal;
5182                 if (is_inf) {
5183                     delta = SSize_t_MAX;
5184                 } else {
5185                     delta += (minnext + deltanext) * maxcount
5186                              - minnext * mincount;
5187                 }
5188                 /* Try powerful optimization CURLYX => CURLYN. */
5189                 if (  OP(oscan) == CURLYX && data
5190                       && data->flags & SF_IN_PAR
5191                       && !(data->flags & SF_HAS_EVAL)
5192                       && !deltanext && minnext == 1 ) {
5193                     /* Try to optimize to CURLYN.  */
5194                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5195                     regnode * const nxt1 = nxt;
5196 #ifdef DEBUGGING
5197                     regnode *nxt2;
5198 #endif
5199
5200                     /* Skip open. */
5201                     nxt = regnext(nxt);
5202                     if (!REGNODE_SIMPLE(OP(nxt))
5203                         && !(PL_regkind[OP(nxt)] == EXACT
5204                              && STR_LEN(nxt) == 1))
5205                         goto nogo;
5206 #ifdef DEBUGGING
5207                     nxt2 = nxt;
5208 #endif
5209                     nxt = regnext(nxt);
5210                     if (OP(nxt) != CLOSE)
5211                         goto nogo;
5212                     if (RExC_open_parens) {
5213                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5214                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5215                     }
5216                     /* Now we know that nxt2 is the only contents: */
5217                     oscan->flags = (U8)ARG(nxt);
5218                     OP(oscan) = CURLYN;
5219                     OP(nxt1) = NOTHING; /* was OPEN. */
5220
5221 #ifdef DEBUGGING
5222                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5223                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5224                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5225                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5226                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5227                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5228 #endif
5229                 }
5230               nogo:
5231
5232                 /* Try optimization CURLYX => CURLYM. */
5233                 if (  OP(oscan) == CURLYX && data
5234                       && !(data->flags & SF_HAS_PAR)
5235                       && !(data->flags & SF_HAS_EVAL)
5236                       && !deltanext     /* atom is fixed width */
5237                       && minnext != 0   /* CURLYM can't handle zero width */
5238
5239                          /* Nor characters whose fold at run-time may be
5240                           * multi-character */
5241                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5242                 ) {
5243                     /* XXXX How to optimize if data == 0? */
5244                     /* Optimize to a simpler form.  */
5245                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5246                     regnode *nxt2;
5247
5248                     OP(oscan) = CURLYM;
5249                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5250                             && (OP(nxt2) != WHILEM))
5251                         nxt = nxt2;
5252                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5253                     /* Need to optimize away parenths. */
5254                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5255                         /* Set the parenth number.  */
5256                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5257
5258                         oscan->flags = (U8)ARG(nxt);
5259                         if (RExC_open_parens) {
5260                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5261                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5262                         }
5263                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5264                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5265
5266 #ifdef DEBUGGING
5267                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5268                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5269                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5270                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5271 #endif
5272 #if 0
5273                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5274                             regnode *nnxt = regnext(nxt1);
5275                             if (nnxt == nxt) {
5276                                 if (reg_off_by_arg[OP(nxt1)])
5277                                     ARG_SET(nxt1, nxt2 - nxt1);
5278                                 else if (nxt2 - nxt1 < U16_MAX)
5279                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5280                                 else
5281                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5282                             }
5283                             nxt1 = nnxt;
5284                         }
5285 #endif
5286                         /* Optimize again: */
5287                         /* recurse study_chunk() on optimised CURLYX => CURLYM */
5288                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5289                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5290                     }
5291                     else
5292                         oscan->flags = 0;
5293                 }
5294                 else if ((OP(oscan) == CURLYX)
5295                          && (flags & SCF_WHILEM_VISITED_POS)
5296                          /* See the comment on a similar expression above.
5297                             However, this time it's not a subexpression
5298                             we care about, but the expression itself. */
5299                          && (maxcount == REG_INFTY)
5300                          && data) {
5301                     /* This stays as CURLYX, we can put the count/of pair. */
5302                     /* Find WHILEM (as in regexec.c) */
5303                     regnode *nxt = oscan + NEXT_OFF(oscan);
5304
5305                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5306                         nxt += ARG(nxt);
5307                     nxt = PREVOPER(nxt);
5308                     if (nxt->flags & 0xf) {
5309                         /* we've already set whilem count on this node */
5310                     } else if (++data->whilem_c < 16) {
5311                         assert(data->whilem_c <= RExC_whilem_seen);
5312                         nxt->flags = (U8)(data->whilem_c
5313                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5314                     }
5315                 }
5316                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5317                     pars++;
5318                 if (flags & SCF_DO_SUBSTR) {
5319                     SV *last_str = NULL;
5320                     STRLEN last_chrs = 0;
5321                     int counted = mincount != 0;
5322
5323                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5324                                                                   string. */
5325                         SSize_t b = pos_before >= data->last_start_min
5326                             ? pos_before : data->last_start_min;
5327                         STRLEN l;
5328                         const char * const s = SvPV_const(data->last_found, l);
5329                         SSize_t old = b - data->last_start_min;
5330
5331                         if (UTF)
5332                             old = utf8_hop((U8*)s, old) - (U8*)s;
5333                         l -= old;
5334                         /* Get the added string: */
5335                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5336                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5337                                             (U8*)(s + old + l)) : l;
5338                         if (deltanext == 0 && pos_before == b) {
5339                             /* What was added is a constant string */
5340                             if (mincount > 1) {
5341
5342                                 SvGROW(last_str, (mincount * l) + 1);
5343                                 repeatcpy(SvPVX(last_str) + l,
5344                                           SvPVX_const(last_str), l,
5345                                           mincount - 1);
5346                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5347                                 /* Add additional parts. */
5348                                 SvCUR_set(data->last_found,
5349                                           SvCUR(data->last_found) - l);
5350                                 sv_catsv(data->last_found, last_str);
5351                                 {
5352                                     SV * sv = data->last_found;
5353                                     MAGIC *mg =
5354                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5355                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5356                                     if (mg && mg->mg_len >= 0)
5357                                         mg->mg_len += last_chrs * (mincount-1);
5358                                 }
5359                                 last_chrs *= mincount;
5360                                 data->last_end += l * (mincount - 1);
5361                             }
5362                         } else {
5363                             /* start offset must point into the last copy */
5364                             data->last_start_min += minnext * (mincount - 1);
5365                             data->last_start_max =
5366                               is_inf
5367                                ? SSize_t_MAX
5368                                : data->last_start_max +
5369                                  (maxcount - 1) * (minnext + data->pos_delta);
5370                         }
5371                     }
5372                     /* It is counted once already... */
5373                     data->pos_min += minnext * (mincount - counted);
5374 #if 0
5375 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5376                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5377                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5378     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5379     (UV)mincount);
5380 if (deltanext != SSize_t_MAX)
5381 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5382     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5383           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5384 #endif
5385                     if (deltanext == SSize_t_MAX
5386                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5387                         data->pos_delta = SSize_t_MAX;
5388                     else
5389                         data->pos_delta += - counted * deltanext +
5390                         (minnext + deltanext) * maxcount - minnext * mincount;
5391                     if (mincount != maxcount) {
5392                          /* Cannot extend fixed substrings found inside
5393                             the group.  */
5394                         scan_commit(pRExC_state, data, minlenp, is_inf);
5395                         if (mincount && last_str) {
5396                             SV * const sv = data->last_found;
5397                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5398                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5399
5400                             if (mg)
5401                                 mg->mg_len = -1;
5402                             sv_setsv(sv, last_str);
5403                             data->last_end = data->pos_min;
5404                             data->last_start_min = data->pos_min - last_chrs;
5405                             data->last_start_max = is_inf
5406                                 ? SSize_t_MAX
5407                                 : data->pos_min + data->pos_delta - last_chrs;
5408                         }
5409                         data->cur_is_floating = 1; /* float */
5410                     }
5411                     SvREFCNT_dec(last_str);
5412                 }
5413                 if (data && (fl & SF_HAS_EVAL))
5414                     data->flags |= SF_HAS_EVAL;
5415               optimize_curly_tail:
5416                 if (OP(oscan) != CURLYX) {
5417                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5418                            && NEXT_OFF(next))
5419                         NEXT_OFF(oscan) += NEXT_OFF(next);
5420                 }
5421                 continue;
5422
5423             default:
5424 #ifdef DEBUGGING
5425                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5426                                                                     OP(scan));
5427 #endif
5428             case REF:
5429             case CLUMP:
5430                 if (flags & SCF_DO_SUBSTR) {
5431                     /* Cannot expect anything... */
5432                     scan_commit(pRExC_state, data, minlenp, is_inf);
5433                     data->cur_is_floating = 1; /* float */
5434                 }
5435                 is_inf = is_inf_internal = 1;
5436                 if (flags & SCF_DO_STCLASS_OR) {
5437                     if (OP(scan) == CLUMP) {
5438                         /* Actually is any start char, but very few code points
5439                          * aren't start characters */
5440                         ssc_match_all_cp(data->start_class);
5441                     }
5442                     else {
5443                         ssc_anything(data->start_class);
5444                     }
5445                 }
5446                 flags &= ~SCF_DO_STCLASS;
5447                 break;
5448             }
5449         }
5450         else if (OP(scan) == LNBREAK) {
5451             if (flags & SCF_DO_STCLASS) {
5452                 if (flags & SCF_DO_STCLASS_AND) {
5453                     ssc_intersection(data->start_class,
5454                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5455                     ssc_clear_locale(data->start_class);
5456                     ANYOF_FLAGS(data->start_class)
5457                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5458                 }
5459                 else if (flags & SCF_DO_STCLASS_OR) {
5460                     ssc_union(data->start_class,
5461                               PL_XPosix_ptrs[_CC_VERTSPACE],
5462                               FALSE);
5463                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5464
5465                     /* See commit msg for
5466                      * 749e076fceedeb708a624933726e7989f2302f6a */
5467                     ANYOF_FLAGS(data->start_class)
5468                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5469                 }
5470                 flags &= ~SCF_DO_STCLASS;
5471             }
5472             min++;
5473             if (delta != SSize_t_MAX)
5474                 delta++;    /* Because of the 2 char string cr-lf */
5475             if (flags & SCF_DO_SUBSTR) {
5476                 /* Cannot expect anything... */
5477                 scan_commit(pRExC_state, data, minlenp, is_inf);
5478                 data->pos_min += 1;
5479                 data->pos_delta += 1;
5480                 data->cur_is_floating = 1; /* float */
5481             }
5482         }
5483         else if (REGNODE_SIMPLE(OP(scan))) {
5484
5485             if (flags & SCF_DO_SUBSTR) {
5486                 scan_commit(pRExC_state, data, minlenp, is_inf);
5487                 data->pos_min++;
5488             }
5489             min++;
5490             if (flags & SCF_DO_STCLASS) {
5491                 bool invert = 0;
5492                 SV* my_invlist = NULL;
5493                 U8 namedclass;
5494
5495                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5496                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5497
5498                 /* Some of the logic below assumes that switching
5499                    locale on will only add false positives. */
5500                 switch (OP(scan)) {
5501
5502                 default:
5503 #ifdef DEBUGGING
5504                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5505                                                                      OP(scan));
5506 #endif
5507                 case SANY:
5508                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5509                         ssc_match_all_cp(data->start_class);
5510                     break;
5511
5512                 case REG_ANY:
5513                     {
5514                         SV* REG_ANY_invlist = _new_invlist(2);
5515                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5516                                                             '\n');
5517                         if (flags & SCF_DO_STCLASS_OR) {
5518                             ssc_union(data->start_class,
5519                                       REG_ANY_invlist,
5520                                       TRUE /* TRUE => invert, hence all but \n
5521                                             */
5522                                       );
5523                         }
5524                         else if (flags & SCF_DO_STCLASS_AND) {
5525                             ssc_intersection(data->start_class,
5526                                              REG_ANY_invlist,
5527                                              TRUE  /* TRUE => invert */
5528                                              );
5529                             ssc_clear_locale(data->start_class);
5530                         }
5531                         SvREFCNT_dec_NN(REG_ANY_invlist);
5532                     }
5533                     break;
5534
5535                 case ANYOFD:
5536                 case ANYOFL:
5537                 case ANYOF:
5538                     if (flags & SCF_DO_STCLASS_AND)
5539                         ssc_and(pRExC_state, data->start_class,
5540                                 (regnode_charclass *) scan);
5541                     else
5542                         ssc_or(pRExC_state, data->start_class,
5543                                                           (regnode_charclass *) scan);
5544                     break;
5545
5546                 case ANYOFM:
5547                   {
5548                     SV* cp_list = get_ANYOFM_contents(scan);
5549
5550                     if (flags & SCF_DO_STCLASS_OR) {
5551                         ssc_union(data->start_class,
5552                                   cp_list,
5553                                   FALSE /* don't invert */
5554                                   );
5555                     }
5556                     else if (flags & SCF_DO_STCLASS_AND) {
5557                         ssc_intersection(data->start_class,
5558                                          cp_list,
5559                                          FALSE /* don't invert */
5560                                          );
5561                     }
5562
5563                     SvREFCNT_dec_NN(cp_list);
5564                     break;
5565                   }
5566
5567                 case NPOSIXL:
5568                     invert = 1;
5569                     /* FALLTHROUGH */
5570
5571                 case POSIXL:
5572                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5573                     if (flags & SCF_DO_STCLASS_AND) {
5574                         bool was_there = cBOOL(
5575                                           ANYOF_POSIXL_TEST(data->start_class,
5576                                                                  namedclass));
5577                         ANYOF_POSIXL_ZERO(data->start_class);
5578                         if (was_there) {    /* Do an AND */
5579                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5580                         }
5581                         /* No individual code points can now match */
5582                         data->start_class->invlist
5583                                                 = sv_2mortal(_new_invlist(0));
5584                     }
5585                     else {
5586                         int complement = namedclass + ((invert) ? -1 : 1);
5587
5588                         assert(flags & SCF_DO_STCLASS_OR);
5589
5590                         /* If the complement of this class was already there,
5591                          * the result is that they match all code points,
5592                          * (\d + \D == everything).  Remove the classes from
5593                          * future consideration.  Locale is not relevant in
5594                          * this case */
5595                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5596                             ssc_match_all_cp(data->start_class);
5597                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5598                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5599                         }
5600                         else {  /* The usual case; just add this class to the
5601                                    existing set */
5602                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5603                         }
5604                     }
5605                     break;
5606
5607                 case NASCII:
5608                     invert = 1;
5609                     /* FALLTHROUGH */
5610                 case ASCII:
5611                     my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5612
5613                     /* This can be handled as a Posix class */
5614                     goto join_posix_and_ascii;
5615
5616                 case NPOSIXA:   /* For these, we always know the exact set of
5617                                    what's matched */
5618                     invert = 1;
5619                     /* FALLTHROUGH */
5620                 case POSIXA:
5621                     assert(FLAGS(scan) != _CC_ASCII);
5622                     _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5623                                           PL_XPosix_ptrs[_CC_ASCII],
5624                                           &my_invlist);
5625                     goto join_posix_and_ascii;
5626
5627                 case NPOSIXD:
5628                 case NPOSIXU:
5629                     invert = 1;
5630                     /* FALLTHROUGH */
5631                 case POSIXD:
5632                 case POSIXU:
5633                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5634
5635                     /* NPOSIXD matches all upper Latin1 code points unless the
5636                      * target string being matched is UTF-8, which is
5637                      * unknowable until match time.  Since we are going to
5638                      * invert, we want to get rid of all of them so that the
5639                      * inversion will match all */
5640                     if (OP(scan) == NPOSIXD) {
5641                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5642                                           &my_invlist);
5643                     }
5644
5645                   join_posix_and_ascii:
5646
5647                     if (flags & SCF_DO_STCLASS_AND) {
5648                         ssc_intersection(data->start_class, my_invlist, invert);
5649                         ssc_clear_locale(data->start_class);
5650                     }
5651                     else {
5652                         assert(flags & SCF_DO_STCLASS_OR);
5653                         ssc_union(data->start_class, my_invlist, invert);
5654                     }
5655                     SvREFCNT_dec(my_invlist);
5656                 }
5657                 if (flags & SCF_DO_STCLASS_OR)
5658                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5659                 flags &= ~SCF_DO_STCLASS;
5660             }
5661         }
5662         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5663             data->flags |= (OP(scan) == MEOL
5664                             ? SF_BEFORE_MEOL
5665                             : SF_BEFORE_SEOL);
5666             scan_commit(pRExC_state, data, minlenp, is_inf);
5667
5668         }
5669         else if (  PL_regkind[OP(scan)] == BRANCHJ
5670                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5671                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5672                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5673         {
5674             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5675                 || OP(scan) == UNLESSM )
5676             {
5677                 /* Negative Lookahead/lookbehind
5678                    In this case we can't do fixed string optimisation.
5679                 */
5680
5681                 SSize_t deltanext, minnext, fake = 0;
5682                 regnode *nscan;
5683                 regnode_ssc intrnl;
5684                 int f = 0;
5685
5686                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5687                 if (data) {
5688                     data_fake.whilem_c = data->whilem_c;
5689                     data_fake.last_closep = data->last_closep;
5690                 }
5691                 else
5692                     data_fake.last_closep = &fake;
5693                 data_fake.pos_delta = delta;
5694                 if ( flags & SCF_DO_STCLASS && !scan->flags
5695                      && OP(scan) == IFMATCH ) { /* Lookahead */
5696                     ssc_init(pRExC_state, &intrnl);
5697                     data_fake.start_class = &intrnl;
5698                     f |= SCF_DO_STCLASS_AND;
5699                 }
5700                 if (flags & SCF_WHILEM_VISITED_POS)
5701                     f |= SCF_WHILEM_VISITED_POS;
5702                 next = regnext(scan);
5703                 nscan = NEXTOPER(NEXTOPER(scan));
5704
5705                 /* recurse study_chunk() for lookahead body */
5706                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5707                                       last, &data_fake, stopparen,
5708                                       recursed_depth, NULL, f, depth+1);
5709                 if (scan->flags) {
5710                     if (deltanext) {
5711                         FAIL("Variable length lookbehind not implemented");
5712                     }
5713                     else if (minnext > (I32)U8_MAX) {
5714                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5715                               (UV)U8_MAX);
5716                     }
5717                     scan->flags = (U8)minnext;
5718                 }
5719                 if (data) {
5720                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5721                         pars++;
5722                     if (data_fake.flags & SF_HAS_EVAL)
5723                         data->flags |= SF_HAS_EVAL;
5724                     data->whilem_c = data_fake.whilem_c;
5725                 }
5726                 if (f & SCF_DO_STCLASS_AND) {
5727                     if (flags & SCF_DO_STCLASS_OR) {
5728                         /* OR before, AND after: ideally we would recurse with
5729                          * data_fake to get the AND applied by study of the
5730                          * remainder of the pattern, and then derecurse;
5731                          * *** HACK *** for now just treat as "no information".
5732                          * See [perl #56690].
5733                          */
5734                         ssc_init(pRExC_state, data->start_class);
5735                     }  else {
5736                         /* AND before and after: combine and continue.  These
5737                          * assertions are zero-length, so can match an EMPTY
5738                          * string */
5739                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5740                         ANYOF_FLAGS(data->start_class)
5741                                                    |= SSC_MATCHES_EMPTY_STRING;
5742                     }
5743                 }
5744             }
5745 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5746             else {
5747                 /* Positive Lookahead/lookbehind
5748                    In this case we can do fixed string optimisation,
5749                    but we must be careful about it. Note in the case of
5750                    lookbehind the positions will be offset by the minimum
5751                    length of the pattern, something we won't know about
5752                    until after the recurse.
5753                 */
5754                 SSize_t deltanext, fake = 0;
5755                 regnode *nscan;
5756                 regnode_ssc intrnl;
5757                 int f = 0;
5758                 /* We use SAVEFREEPV so that when the full compile
5759                     is finished perl will clean up the allocated
5760                     minlens when it's all done. This way we don't
5761                     have to worry about freeing them when we know
5762                     they wont be used, which would be a pain.
5763                  */
5764                 SSize_t *minnextp;
5765                 Newx( minnextp, 1, SSize_t );
5766                 SAVEFREEPV(minnextp);
5767
5768                 if (data) {
5769                     StructCopy(data, &data_fake, scan_data_t);
5770                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5771                         f |= SCF_DO_SUBSTR;
5772                         if (scan->flags)
5773                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5774                         data_fake.last_found=newSVsv(data->last_found);
5775                     }
5776                 }
5777                 else
5778                     data_fake.last_closep = &fake;
5779                 data_fake.flags = 0;
5780                 data_fake.substrs[0].flags = 0;
5781                 data_fake.substrs[1].flags = 0;
5782                 data_fake.pos_delta = delta;
5783                 if (is_inf)
5784                     data_fake.flags |= SF_IS_INF;
5785                 if ( flags & SCF_DO_STCLASS && !scan->flags
5786                      && OP(scan) == IFMATCH ) { /* Lookahead */
5787                     ssc_init(pRExC_state, &intrnl);
5788                     data_fake.start_class = &intrnl;
5789                     f |= SCF_DO_STCLASS_AND;
5790                 }
5791                 if (flags & SCF_WHILEM_VISITED_POS)
5792                     f |= SCF_WHILEM_VISITED_POS;
5793                 next = regnext(scan);
5794                 nscan = NEXTOPER(NEXTOPER(scan));
5795
5796                 /* positive lookahead study_chunk() recursion */
5797                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5798                                         &deltanext, last, &data_fake,
5799                                         stopparen, recursed_depth, NULL,
5800                                         f,depth+1);
5801                 if (scan->flags) {
5802                     if (deltanext) {
5803                         FAIL("Variable length lookbehind not implemented");
5804                     }
5805                     else if (*minnextp > (I32)U8_MAX) {
5806                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5807                               (UV)U8_MAX);
5808                     }
5809                     scan->flags = (U8)*minnextp;
5810                 }
5811
5812                 *minnextp += min;
5813
5814                 if (f & SCF_DO_STCLASS_AND) {
5815                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5816                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5817                 }
5818                 if (data) {
5819                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5820                         pars++;
5821                     if (data_fake.flags & SF_HAS_EVAL)
5822                         data->flags |= SF_HAS_EVAL;
5823                     data->whilem_c = data_fake.whilem_c;
5824                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5825                         int i;
5826                         if (RExC_rx->minlen<*minnextp)
5827                             RExC_rx->minlen=*minnextp;
5828                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5829                         SvREFCNT_dec_NN(data_fake.last_found);
5830
5831                         for (i = 0; i < 2; i++) {
5832                             if (data_fake.substrs[i].minlenp != minlenp) {
5833                                 data->substrs[i].min_offset =
5834                                             data_fake.substrs[i].min_offset;
5835                                 data->substrs[i].max_offset =
5836                                             data_fake.substrs[i].max_offset;
5837                                 data->substrs[i].minlenp =
5838                                             data_fake.substrs[i].minlenp;
5839                                 data->substrs[i].lookbehind += scan->flags;
5840                             }
5841                         }
5842                     }
5843                 }
5844             }
5845 #endif
5846         }
5847
5848         else if (OP(scan) == OPEN) {
5849             if (stopparen != (I32)ARG(scan))
5850                 pars++;
5851         }
5852         else if (OP(scan) == CLOSE) {
5853             if (stopparen == (I32)ARG(scan)) {
5854                 break;
5855             }
5856             if ((I32)ARG(scan) == is_par) {
5857                 next = regnext(scan);
5858
5859                 if ( next && (OP(next) != WHILEM) && next < last)
5860                     is_par = 0;         /* Disable optimization */
5861             }
5862             if (data)
5863                 *(data->last_closep) = ARG(scan);
5864         }
5865         else if (OP(scan) == EVAL) {
5866                 if (data)
5867                     data->flags |= SF_HAS_EVAL;
5868         }
5869         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5870             if (flags & SCF_DO_SUBSTR) {
5871                 scan_commit(pRExC_state, data, minlenp, is_inf);
5872                 flags &= ~SCF_DO_SUBSTR;
5873             }
5874             if (data && OP(scan)==ACCEPT) {
5875                 data->flags |= SCF_SEEN_ACCEPT;
5876                 if (stopmin > min)
5877                     stopmin = min;
5878             }
5879         }
5880         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5881         {
5882                 if (flags & SCF_DO_SUBSTR) {
5883                     scan_commit(pRExC_state, data, minlenp, is_inf);
5884                     data->cur_is_floating = 1; /* float */
5885                 }
5886                 is_inf = is_inf_internal = 1;
5887                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5888                     ssc_anything(data->start_class);
5889                 flags &= ~SCF_DO_STCLASS;
5890         }
5891         else if (OP(scan) == GPOS) {
5892             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5893                 !(delta || is_inf || (data && data->pos_delta)))
5894             {
5895                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5896                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5897                 if (RExC_rx->gofs < (STRLEN)min)
5898                     RExC_rx->gofs = min;
5899             } else {
5900                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5901                 RExC_rx->gofs = 0;
5902             }
5903         }
5904 #ifdef TRIE_STUDY_OPT
5905 #ifdef FULL_TRIE_STUDY
5906         else if (PL_regkind[OP(scan)] == TRIE) {
5907             /* NOTE - There is similar code to this block above for handling
5908                BRANCH nodes on the initial study.  If you change stuff here
5909                check there too. */
5910             regnode *trie_node= scan;
5911             regnode *tail= regnext(scan);
5912             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5913             SSize_t max1 = 0, min1 = SSize_t_MAX;
5914             regnode_ssc accum;
5915
5916             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5917                 /* Cannot merge strings after this. */
5918                 scan_commit(pRExC_state, data, minlenp, is_inf);
5919             }
5920             if (flags & SCF_DO_STCLASS)
5921                 ssc_init_zero(pRExC_state, &accum);
5922
5923             if (!trie->jump) {
5924                 min1= trie->minlen;
5925                 max1= trie->maxlen;
5926             } else {
5927                 const regnode *nextbranch= NULL;
5928                 U32 word;
5929
5930                 for ( word=1 ; word <= trie->wordcount ; word++)
5931                 {
5932                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5933                     regnode_ssc this_class;
5934
5935                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5936                     if (data) {
5937                         data_fake.whilem_c = data->whilem_c;
5938                         data_fake.last_closep = data->last_closep;
5939                     }
5940                     else
5941                         data_fake.last_closep = &fake;
5942                     data_fake.pos_delta = delta;
5943                     if (flags & SCF_DO_STCLASS) {
5944                         ssc_init(pRExC_state, &this_class);
5945                         data_fake.start_class = &this_class;
5946                         f = SCF_DO_STCLASS_AND;
5947                     }
5948                     if (flags & SCF_WHILEM_VISITED_POS)
5949                         f |= SCF_WHILEM_VISITED_POS;
5950
5951                     if (trie->jump[word]) {
5952                         if (!nextbranch)
5953                             nextbranch = trie_node + trie->jump[0];
5954                         scan= trie_node + trie->jump[word];
5955                         /* We go from the jump point to the branch that follows
5956                            it. Note this means we need the vestigal unused
5957                            branches even though they arent otherwise used. */
5958                         /* optimise study_chunk() for TRIE */
5959                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5960                             &deltanext, (regnode *)nextbranch, &data_fake,
5961                             stopparen, recursed_depth, NULL, f,depth+1);
5962                     }
5963                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5964                         nextbranch= regnext((regnode*)nextbranch);
5965
5966                     if (min1 > (SSize_t)(minnext + trie->minlen))
5967                         min1 = minnext + trie->minlen;
5968                     if (deltanext == SSize_t_MAX) {
5969                         is_inf = is_inf_internal = 1;
5970                         max1 = SSize_t_MAX;
5971                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5972                         max1 = minnext + deltanext + trie->maxlen;
5973
5974                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5975                         pars++;
5976                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5977                         if ( stopmin > min + min1)
5978                             stopmin = min + min1;
5979                         flags &= ~SCF_DO_SUBSTR;
5980                         if (data)
5981                             data->flags |= SCF_SEEN_ACCEPT;
5982                     }
5983                     if (data) {
5984                         if (data_fake.flags & SF_HAS_EVAL)
5985                             data->flags |= SF_HAS_EVAL;
5986                         data->whilem_c = data_fake.whilem_c;
5987                     }
5988                     if (flags & SCF_DO_STCLASS)
5989                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5990                 }
5991             }
5992             if (flags & SCF_DO_SUBSTR) {
5993                 data->pos_min += min1;
5994                 data->pos_delta += max1 - min1;
5995                 if (max1 != min1 || is_inf)
5996                     data->cur_is_floating = 1; /* float */
5997             }
5998             min += min1;
5999             if (delta != SSize_t_MAX) {
6000                 if (SSize_t_MAX - (max1 - min1) >= delta)
6001                     delta += max1 - min1;
6002                 else
6003                     delta = SSize_t_MAX;
6004             }
6005             if (flags & SCF_DO_STCLASS_OR) {
6006                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6007                 if (min1) {
6008                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6009                     flags &= ~SCF_DO_STCLASS;
6010                 }
6011             }
6012             else if (flags & SCF_DO_STCLASS_AND) {
6013                 if (min1) {
6014                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6015                     flags &= ~SCF_DO_STCLASS;
6016                 }
6017                 else {
6018                     /* Switch to OR mode: cache the old value of
6019                      * data->start_class */
6020                     INIT_AND_WITHP;
6021                     StructCopy(data->start_class, and_withp, regnode_ssc);
6022                     flags &= ~SCF_DO_STCLASS_AND;
6023                     StructCopy(&accum, data->start_class, regnode_ssc);
6024                     flags |= SCF_DO_STCLASS_OR;
6025                 }
6026             }
6027             scan= tail;
6028             continue;
6029         }
6030 #else
6031         else if (PL_regkind[OP(scan)] == TRIE) {
6032             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6033             U8*bang=NULL;
6034
6035             min += trie->minlen;
6036             delta += (trie->maxlen - trie->minlen);
6037             flags &= ~SCF_DO_STCLASS; /* xxx */
6038             if (flags & SCF_DO_SUBSTR) {
6039                 /* Cannot expect anything... */
6040                 scan_commit(pRExC_state, data, minlenp, is_inf);
6041                 data->pos_min += trie->minlen;
6042                 data->pos_delta += (trie->maxlen - trie->minlen);
6043                 if (trie->maxlen != trie->minlen)
6044                     data->cur_is_floating = 1; /* float */
6045             }
6046             if (trie->jump) /* no more substrings -- for now /grr*/
6047                flags &= ~SCF_DO_SUBSTR;
6048         }
6049 #endif /* old or new */
6050 #endif /* TRIE_STUDY_OPT */
6051
6052         /* Else: zero-length, ignore. */
6053         scan = regnext(scan);
6054     }
6055
6056   finish:
6057     if (frame) {
6058         /* we need to unwind recursion. */
6059         depth = depth - 1;
6060
6061         DEBUG_STUDYDATA("frame-end", data, depth, is_inf);
6062         DEBUG_PEEP("fend", scan, depth, flags);
6063
6064         /* restore previous context */
6065         last = frame->last_regnode;
6066         scan = frame->next_regnode;
6067         stopparen = frame->stopparen;
6068         recursed_depth = frame->prev_recursed_depth;
6069
6070         RExC_frame_last = frame->prev_frame;
6071         frame = frame->this_prev_frame;
6072         goto fake_study_recurse;
6073     }
6074
6075     assert(!frame);
6076     DEBUG_STUDYDATA("pre-fin", data, depth, is_inf);
6077
6078     *scanp = scan;
6079     *deltap = is_inf_internal ? SSize_t_MAX : delta;
6080
6081     if (flags & SCF_DO_SUBSTR && is_inf)
6082         data->pos_delta = SSize_t_MAX - data->pos_min;
6083     if (is_par > (I32)U8_MAX)
6084         is_par = 0;
6085     if (is_par && pars==1 && data) {
6086         data->flags |= SF_IN_PAR;
6087         data->flags &= ~SF_HAS_PAR;
6088     }
6089     else if (pars && data) {
6090         data->flags |= SF_HAS_PAR;
6091         data->flags &= ~SF_IN_PAR;
6092     }
6093     if (flags & SCF_DO_STCLASS_OR)
6094         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6095     if (flags & SCF_TRIE_RESTUDY)
6096         data->flags |=  SCF_TRIE_RESTUDY;
6097
6098     DEBUG_STUDYDATA("post-fin", data, depth, is_inf);
6099
6100     {
6101         SSize_t final_minlen= min < stopmin ? min : stopmin;
6102
6103         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
6104             if (final_minlen > SSize_t_MAX - delta)
6105                 RExC_maxlen = SSize_t_MAX;
6106             else if (RExC_maxlen < final_minlen + delta)
6107                 RExC_maxlen = final_minlen + delta;
6108         }
6109         return final_minlen;
6110     }
6111     NOT_REACHED; /* NOTREACHED */
6112 }
6113
6114 STATIC U32
6115 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
6116 {
6117     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
6118
6119     PERL_ARGS_ASSERT_ADD_DATA;
6120
6121     Renewc(RExC_rxi->data,
6122            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6123            char, struct reg_data);
6124     if(count)
6125         Renew(RExC_rxi->data->what, count + n, U8);
6126     else
6127         Newx(RExC_rxi->data->what, n, U8);
6128     RExC_rxi->data->count = count + n;
6129     Copy(s, RExC_rxi->data->what + count, n, U8);
6130     return count;
6131 }
6132
6133 /*XXX: todo make this not included in a non debugging perl, but appears to be
6134  * used anyway there, in 'use re' */
6135 #ifndef PERL_IN_XSUB_RE
6136 void
6137 Perl_reginitcolors(pTHX)
6138 {
6139     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6140     if (s) {
6141         char *t = savepv(s);
6142         int i = 0;
6143         PL_colors[0] = t;
6144         while (++i < 6) {
6145             t = strchr(t, '\t');
6146             if (t) {
6147                 *t = '\0';
6148                 PL_colors[i] = ++t;
6149             }
6150             else
6151                 PL_colors[i] = t = (char *)"";
6152         }
6153     } else {
6154         int i = 0;
6155         while (i < 6)
6156             PL_colors[i++] = (char *)"";
6157     }
6158     PL_colorset = 1;
6159 }
6160 #endif
6161
6162
6163 #ifdef TRIE_STUDY_OPT
6164 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6165     STMT_START {                                            \
6166         if (                                                \
6167               (data.flags & SCF_TRIE_RESTUDY)               \
6168               && ! restudied++                              \
6169         ) {                                                 \
6170             dOsomething;                                    \
6171             goto reStudy;                                   \
6172         }                                                   \
6173     } STMT_END
6174 #else
6175 #define CHECK_RESTUDY_GOTO_butfirst
6176 #endif
6177
6178 /*
6179  * pregcomp - compile a regular expression into internal code
6180  *
6181  * Decides which engine's compiler to call based on the hint currently in
6182  * scope
6183  */
6184
6185 #ifndef PERL_IN_XSUB_RE
6186
6187 /* return the currently in-scope regex engine (or the default if none)  */
6188
6189 regexp_engine const *
6190 Perl_current_re_engine(pTHX)
6191 {
6192     if (IN_PERL_COMPILETIME) {
6193         HV * const table = GvHV(PL_hintgv);
6194         SV **ptr;
6195
6196         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6197             return &PL_core_reg_engine;
6198         ptr = hv_fetchs(table, "regcomp", FALSE);
6199         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6200             return &PL_core_reg_engine;
6201         return INT2PTR(regexp_engine*,SvIV(*ptr));
6202     }
6203     else {
6204         SV *ptr;
6205         if (!PL_curcop->cop_hints_hash)
6206             return &PL_core_reg_engine;
6207         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6208         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6209             return &PL_core_reg_engine;
6210         return INT2PTR(regexp_engine*,SvIV(ptr));
6211     }
6212 }
6213
6214
6215 REGEXP *
6216 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6217 {
6218     regexp_engine const *eng = current_re_engine();
6219     GET_RE_DEBUG_FLAGS_DECL;
6220
6221     PERL_ARGS_ASSERT_PREGCOMP;
6222
6223     /* Dispatch a request to compile a regexp to correct regexp engine. */
6224     DEBUG_COMPILE_r({
6225         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6226                         PTR2UV(eng));
6227     });
6228     return CALLREGCOMP_ENG(eng, pattern, flags);
6229 }
6230 #endif
6231
6232 /* public(ish) entry point for the perl core's own regex compiling code.
6233  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6234  * pattern rather than a list of OPs, and uses the internal engine rather
6235  * than the current one */
6236
6237 REGEXP *
6238 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6239 {
6240     SV *pat = pattern; /* defeat constness! */
6241     PERL_ARGS_ASSERT_RE_COMPILE;
6242     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6243 #ifdef PERL_IN_XSUB_RE
6244                                 &my_reg_engine,
6245 #else
6246                                 &PL_core_reg_engine,
6247 #endif
6248                                 NULL, NULL, rx_flags, 0);
6249 }
6250
6251
6252 static void
6253 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6254 {
6255     int n;
6256
6257     if (--cbs->refcnt > 0)
6258         return;
6259     for (n = 0; n < cbs->count; n++) {
6260         REGEXP *rx = cbs->cb[n].src_regex;
6261         cbs->cb[n].src_regex = NULL;
6262         SvREFCNT_dec(rx);
6263     }
6264     Safefree(cbs->cb);
6265     Safefree(cbs);
6266 }
6267
6268
6269 static struct reg_code_blocks *
6270 S_alloc_code_blocks(pTHX_  int ncode)
6271 {
6272      struct reg_code_blocks *cbs;
6273     Newx(cbs, 1, struct reg_code_blocks);
6274     cbs->count = ncode;
6275     cbs->refcnt = 1;
6276     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6277     if (ncode)
6278         Newx(cbs->cb, ncode, struct reg_code_block);
6279     else
6280         cbs->cb = NULL;
6281     return cbs;
6282 }
6283
6284
6285 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6286  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6287  * point to the realloced string and length.
6288  *
6289  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6290  * stuff added */
6291
6292 static void
6293 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6294                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6295 {
6296     U8 *const src = (U8*)*pat_p;
6297     U8 *dst, *d;
6298     int n=0;
6299     STRLEN s = 0;
6300     bool do_end = 0;
6301     GET_RE_DEBUG_FLAGS_DECL;
6302
6303     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6304         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6305
6306     Newx(dst, *plen_p * 2 + 1, U8);
6307     d = dst;
6308
6309     while (s < *plen_p) {
6310         append_utf8_from_native_byte(src[s], &d);
6311
6312         if (n < num_code_blocks) {
6313             assert(pRExC_state->code_blocks);
6314             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6315                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6316                 assert(*(d - 1) == '(');
6317                 do_end = 1;
6318             }
6319             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6320                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6321                 assert(*(d - 1) == ')');
6322                 do_end = 0;
6323                 n++;
6324             }
6325         }
6326         s++;
6327     }
6328     *d = '\0';
6329     *plen_p = d - dst;
6330     *pat_p = (char*) dst;
6331     SAVEFREEPV(*pat_p);
6332     RExC_orig_utf8 = RExC_utf8 = 1;
6333 }
6334
6335
6336
6337 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6338  * while recording any code block indices, and handling overloading,
6339  * nested qr// objects etc.  If pat is null, it will allocate a new
6340  * string, or just return the first arg, if there's only one.
6341  *
6342  * Returns the malloced/updated pat.
6343  * patternp and pat_count is the array of SVs to be concatted;
6344  * oplist is the optional list of ops that generated the SVs;
6345  * recompile_p is a pointer to a boolean that will be set if
6346  *   the regex will need to be recompiled.
6347  * delim, if non-null is an SV that will be inserted between each element
6348  */
6349
6350 static SV*
6351 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6352                 SV *pat, SV ** const patternp, int pat_count,
6353                 OP *oplist, bool *recompile_p, SV *delim)
6354 {
6355     SV **svp;
6356     int n = 0;
6357     bool use_delim = FALSE;
6358     bool alloced = FALSE;
6359
6360     /* if we know we have at least two args, create an empty string,
6361      * then concatenate args to that. For no args, return an empty string */
6362     if (!pat && pat_count != 1) {
6363         pat = newSVpvs("");
6364         SAVEFREESV(pat);
6365         alloced = TRUE;
6366     }
6367
6368     for (svp = patternp; svp < patternp + pat_count; svp++) {
6369         SV *sv;
6370         SV *rx  = NULL;
6371         STRLEN orig_patlen = 0;
6372         bool code = 0;
6373         SV *msv = use_delim ? delim : *svp;
6374         if (!msv) msv = &PL_sv_undef;
6375
6376         /* if we've got a delimiter, we go round the loop twice for each
6377          * svp slot (except the last), using the delimiter the second
6378          * time round */
6379         if (use_delim) {
6380             svp--;
6381             use_delim = FALSE;
6382         }
6383         else if (delim)
6384             use_delim = TRUE;
6385
6386         if (SvTYPE(msv) == SVt_PVAV) {
6387             /* we've encountered an interpolated array within
6388              * the pattern, e.g. /...@a..../. Expand the list of elements,
6389              * then recursively append elements.
6390              * The code in this block is based on S_pushav() */
6391
6392             AV *const av = (AV*)msv;
6393             const SSize_t maxarg = AvFILL(av) + 1;
6394             SV **array;
6395
6396             if (oplist) {
6397                 assert(oplist->op_type == OP_PADAV
6398                     || oplist->op_type == OP_RV2AV);
6399                 oplist = OpSIBLING(oplist);
6400             }
6401
6402             if (SvRMAGICAL(av)) {
6403                 SSize_t i;
6404
6405                 Newx(array, maxarg, SV*);
6406                 SAVEFREEPV(array);
6407                 for (i=0; i < maxarg; i++) {
6408                     SV ** const svp = av_fetch(av, i, FALSE);
6409                     array[i] = svp ? *svp : &PL_sv_undef;
6410                 }
6411             }
6412             else
6413                 array = AvARRAY(av);
6414
6415             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6416                                 array, maxarg, NULL, recompile_p,
6417                                 /* $" */
6418                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6419
6420             continue;
6421         }
6422
6423
6424         /* we make the assumption here that each op in the list of
6425          * op_siblings maps to one SV pushed onto the stack,
6426          * except for code blocks, with have both an OP_NULL and
6427          * and OP_CONST.
6428          * This allows us to match up the list of SVs against the
6429          * list of OPs to find the next code block.
6430          *
6431          * Note that       PUSHMARK PADSV PADSV ..
6432          * is optimised to
6433          *                 PADRANGE PADSV  PADSV  ..
6434          * so the alignment still works. */
6435
6436         if (oplist) {
6437             if (oplist->op_type == OP_NULL
6438                 && (oplist->op_flags & OPf_SPECIAL))
6439             {
6440                 assert(n < pRExC_state->code_blocks->count);
6441                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6442                 pRExC_state->code_blocks->cb[n].block = oplist;
6443                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6444                 n++;
6445                 code = 1;
6446                 oplist = OpSIBLING(oplist); /* skip CONST */
6447                 assert(oplist);
6448             }
6449             oplist = OpSIBLING(oplist);;
6450         }
6451
6452         /* apply magic and QR overloading to arg */
6453
6454         SvGETMAGIC(msv);
6455         if (SvROK(msv) && SvAMAGIC(msv)) {
6456             SV *sv = AMG_CALLunary(msv, regexp_amg);
6457             if (sv) {
6458                 if (SvROK(sv))
6459                     sv = SvRV(sv);
6460                 if (SvTYPE(sv) != SVt_REGEXP)
6461                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6462                 msv = sv;
6463             }
6464         }
6465
6466         /* try concatenation overload ... */
6467         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6468                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6469         {
6470             sv_setsv(pat, sv);
6471             /* overloading involved: all bets are off over literal
6472              * code. Pretend we haven't seen it */
6473             if (n)
6474                 pRExC_state->code_blocks->count -= n;
6475             n = 0;
6476         }
6477         else  {
6478             /* ... or failing that, try "" overload */
6479             while (SvAMAGIC(msv)
6480                     && (sv = AMG_CALLunary(msv, string_amg))
6481                     && sv != msv
6482                     &&  !(   SvROK(msv)
6483                           && SvROK(sv)
6484                           && SvRV(msv) == SvRV(sv))
6485             ) {
6486                 msv = sv;
6487                 SvGETMAGIC(msv);
6488             }
6489             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6490                 msv = SvRV(msv);
6491
6492             if (pat) {
6493                 /* this is a partially unrolled
6494                  *     sv_catsv_nomg(pat, msv);
6495                  * that allows us to adjust code block indices if
6496                  * needed */
6497                 STRLEN dlen;
6498                 char *dst = SvPV_force_nomg(pat, dlen);
6499                 orig_patlen = dlen;
6500                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6501                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6502                     sv_setpvn(pat, dst, dlen);
6503                     SvUTF8_on(pat);
6504                 }
6505                 sv_catsv_nomg(pat, msv);
6506                 rx = msv;
6507             }
6508             else {
6509                 /* We have only one SV to process, but we need to verify
6510                  * it is properly null terminated or we will fail asserts
6511                  * later. In theory we probably shouldn't get such SV's,
6512                  * but if we do we should handle it gracefully. */
6513                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) ) {
6514                     /* not a string, or a string with a trailing null */
6515                     pat = msv;
6516                 } else {
6517                     /* a string with no trailing null, we need to copy it
6518                      * so it has a trailing null */
6519                     pat = sv_2mortal(newSVsv(msv));
6520                 }
6521             }
6522
6523             if (code)
6524                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
6525         }
6526
6527         /* extract any code blocks within any embedded qr//'s */
6528         if (rx && SvTYPE(rx) == SVt_REGEXP
6529             && RX_ENGINE((REGEXP*)rx)->op_comp)
6530         {
6531
6532             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6533             if (ri->code_blocks && ri->code_blocks->count) {
6534                 int i;
6535                 /* the presence of an embedded qr// with code means
6536                  * we should always recompile: the text of the
6537                  * qr// may not have changed, but it may be a
6538                  * different closure than last time */
6539                 *recompile_p = 1;
6540                 if (pRExC_state->code_blocks) {
6541                     int new_count = pRExC_state->code_blocks->count
6542                             + ri->code_blocks->count;
6543                     Renew(pRExC_state->code_blocks->cb,
6544                             new_count, struct reg_code_block);
6545                     pRExC_state->code_blocks->count = new_count;
6546                 }
6547                 else
6548                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
6549                                                     ri->code_blocks->count);
6550
6551                 for (i=0; i < ri->code_blocks->count; i++) {
6552                     struct reg_code_block *src, *dst;
6553                     STRLEN offset =  orig_patlen
6554                         + ReANY((REGEXP *)rx)->pre_prefix;
6555                     assert(n < pRExC_state->code_blocks->count);
6556                     src = &ri->code_blocks->cb[i];
6557                     dst = &pRExC_state->code_blocks->cb[n];
6558                     dst->start      = src->start + offset;
6559                     dst->end        = src->end   + offset;
6560                     dst->block      = src->block;
6561                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6562                                             src->src_regex
6563                                                 ? src->src_regex
6564                                                 : (REGEXP*)rx);
6565                     n++;
6566                 }
6567             }
6568         }
6569     }
6570     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6571     if (alloced)
6572         SvSETMAGIC(pat);
6573
6574     return pat;
6575 }
6576
6577
6578
6579 /* see if there are any run-time code blocks in the pattern.
6580  * False positives are allowed */
6581
6582 static bool
6583 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6584                     char *pat, STRLEN plen)
6585 {
6586     int n = 0;
6587     STRLEN s;
6588     
6589     PERL_UNUSED_CONTEXT;
6590
6591     for (s = 0; s < plen; s++) {
6592         if (   pRExC_state->code_blocks
6593             && n < pRExC_state->code_blocks->count
6594             && s == pRExC_state->code_blocks->cb[n].start)
6595         {
6596             s = pRExC_state->code_blocks->cb[n].end;
6597             n++;
6598             continue;
6599         }
6600         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6601          * positives here */
6602         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6603             (pat[s+2] == '{'
6604                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6605         )
6606             return 1;
6607     }
6608     return 0;
6609 }
6610
6611 /* Handle run-time code blocks. We will already have compiled any direct
6612  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6613  * copy of it, but with any literal code blocks blanked out and
6614  * appropriate chars escaped; then feed it into
6615  *
6616  *    eval "qr'modified_pattern'"
6617  *
6618  * For example,
6619  *
6620  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6621  *
6622  * becomes
6623  *
6624  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6625  *
6626  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6627  * and merge them with any code blocks of the original regexp.
6628  *
6629  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6630  * instead, just save the qr and return FALSE; this tells our caller that
6631  * the original pattern needs upgrading to utf8.
6632  */
6633
6634 static bool
6635 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6636     char *pat, STRLEN plen)
6637 {
6638     SV *qr;
6639
6640     GET_RE_DEBUG_FLAGS_DECL;
6641
6642     if (pRExC_state->runtime_code_qr) {
6643         /* this is the second time we've been called; this should
6644          * only happen if the main pattern got upgraded to utf8
6645          * during compilation; re-use the qr we compiled first time
6646          * round (which should be utf8 too)
6647          */
6648         qr = pRExC_state->runtime_code_qr;
6649         pRExC_state->runtime_code_qr = NULL;
6650         assert(RExC_utf8 && SvUTF8(qr));
6651     }
6652     else {
6653         int n = 0;
6654         STRLEN s;
6655         char *p, *newpat;
6656         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
6657         SV *sv, *qr_ref;
6658         dSP;
6659
6660         /* determine how many extra chars we need for ' and \ escaping */
6661         for (s = 0; s < plen; s++) {
6662             if (pat[s] == '\'' || pat[s] == '\\')
6663                 newlen++;
6664         }
6665
6666         Newx(newpat, newlen, char);
6667         p = newpat;
6668         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6669
6670         for (s = 0; s < plen; s++) {
6671             if (   pRExC_state->code_blocks
6672                 && n < pRExC_state->code_blocks->count
6673                 && s == pRExC_state->code_blocks->cb[n].start)
6674             {
6675                 /* blank out literal code block */
6676                 assert(pat[s] == '(');
6677                 while (s <= pRExC_state->code_blocks->cb[n].end) {
6678                     *p++ = '_';
6679                     s++;
6680                 }
6681                 s--;
6682                 n++;
6683                 continue;
6684             }
6685             if (pat[s] == '\'' || pat[s] == '\\')
6686                 *p++ = '\\';
6687             *p++ = pat[s];
6688         }
6689         *p++ = '\'';
6690         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
6691             *p++ = 'x';
6692             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
6693                 *p++ = 'x';
6694             }
6695         }
6696         *p++ = '\0';
6697         DEBUG_COMPILE_r({
6698             Perl_re_printf( aTHX_
6699                 "%sre-parsing pattern for runtime code:%s %s\n",
6700                 PL_colors[4],PL_colors[5],newpat);
6701         });
6702
6703         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6704         Safefree(newpat);
6705
6706         ENTER;
6707         SAVETMPS;
6708         save_re_context();
6709         PUSHSTACKi(PERLSI_REQUIRE);
6710         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6711          * parsing qr''; normally only q'' does this. It also alters
6712          * hints handling */
6713         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6714         SvREFCNT_dec_NN(sv);
6715         SPAGAIN;
6716         qr_ref = POPs;
6717         PUTBACK;
6718         {
6719             SV * const errsv = ERRSV;
6720             if (SvTRUE_NN(errsv))
6721                 /* use croak_sv ? */
6722                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
6723         }
6724         assert(SvROK(qr_ref));
6725         qr = SvRV(qr_ref);
6726         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6727         /* the leaving below frees the tmp qr_ref.
6728          * Give qr a life of its own */
6729         SvREFCNT_inc(qr);
6730         POPSTACK;
6731         FREETMPS;
6732         LEAVE;
6733
6734     }
6735
6736     if (!RExC_utf8 && SvUTF8(qr)) {
6737         /* first time through; the pattern got upgraded; save the
6738          * qr for the next time through */
6739         assert(!pRExC_state->runtime_code_qr);
6740         pRExC_state->runtime_code_qr = qr;
6741         return 0;
6742     }
6743
6744
6745     /* extract any code blocks within the returned qr//  */
6746
6747
6748     /* merge the main (r1) and run-time (r2) code blocks into one */
6749     {
6750         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6751         struct reg_code_block *new_block, *dst;
6752         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6753         int i1 = 0, i2 = 0;
6754         int r1c, r2c;
6755
6756         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
6757         {
6758             SvREFCNT_dec_NN(qr);
6759             return 1;
6760         }
6761
6762         if (!r1->code_blocks)
6763             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
6764
6765         r1c = r1->code_blocks->count;
6766         r2c = r2->code_blocks->count;
6767
6768         Newx(new_block, r1c + r2c, struct reg_code_block);
6769
6770         dst = new_block;
6771
6772         while (i1 < r1c || i2 < r2c) {
6773             struct reg_code_block *src;
6774             bool is_qr = 0;
6775
6776             if (i1 == r1c) {
6777                 src = &r2->code_blocks->cb[i2++];
6778                 is_qr = 1;
6779             }
6780             else if (i2 == r2c)
6781                 src = &r1->code_blocks->cb[i1++];
6782             else if (  r1->code_blocks->cb[i1].start
6783                      < r2->code_blocks->cb[i2].start)
6784             {
6785                 src = &r1->code_blocks->cb[i1++];
6786                 assert(src->end < r2->code_blocks->cb[i2].start);
6787             }
6788             else {
6789                 assert(  r1->code_blocks->cb[i1].start
6790                        > r2->code_blocks->cb[i2].start);
6791                 src = &r2->code_blocks->cb[i2++];
6792                 is_qr = 1;
6793                 assert(src->end < r1->code_blocks->cb[i1].start);
6794             }
6795
6796             assert(pat[src->start] == '(');
6797             assert(pat[src->end]   == ')');
6798             dst->start      = src->start;
6799             dst->end        = src->end;
6800             dst->block      = src->block;
6801             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6802                                     : src->src_regex;
6803             dst++;
6804         }
6805         r1->code_blocks->count += r2c;
6806         Safefree(r1->code_blocks->cb);
6807         r1->code_blocks->cb = new_block;
6808     }
6809
6810     SvREFCNT_dec_NN(qr);
6811     return 1;
6812 }
6813
6814
6815 STATIC bool
6816 S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
6817                       struct reg_substr_datum  *rsd,
6818                       struct scan_data_substrs *sub,
6819                       STRLEN longest_length)
6820 {
6821     /* This is the common code for setting up the floating and fixed length
6822      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6823      * as to whether succeeded or not */
6824
6825     I32 t;
6826     SSize_t ml;
6827     bool eol  = cBOOL(sub->flags & SF_BEFORE_EOL);
6828     bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
6829
6830     if (! (longest_length
6831            || (eol /* Can't have SEOL and MULTI */
6832                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6833           )
6834             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6835         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6836     {
6837         return FALSE;
6838     }
6839
6840     /* copy the information about the longest from the reg_scan_data
6841         over to the program. */
6842     if (SvUTF8(sub->str)) {
6843         rsd->substr      = NULL;
6844         rsd->utf8_substr = sub->str;
6845     } else {
6846         rsd->substr      = sub->str;
6847         rsd->utf8_substr = NULL;
6848     }
6849     /* end_shift is how many chars that must be matched that
6850         follow this item. We calculate it ahead of time as once the
6851         lookbehind offset is added in we lose the ability to correctly
6852         calculate it.*/
6853     ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
6854     rsd->end_shift = ml - sub->min_offset
6855         - longest_length
6856             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
6857              * intead? - DAPM
6858             + (SvTAIL(sub->str) != 0)
6859             */
6860         + sub->lookbehind;
6861
6862     t = (eol/* Can't have SEOL and MULTI */
6863          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6864     fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
6865
6866     return TRUE;
6867 }
6868
6869 /*
6870  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6871  * regular expression into internal code.
6872  * The pattern may be passed either as:
6873  *    a list of SVs (patternp plus pat_count)
6874  *    a list of OPs (expr)
6875  * If both are passed, the SV list is used, but the OP list indicates
6876  * which SVs are actually pre-compiled code blocks
6877  *
6878  * The SVs in the list have magic and qr overloading applied to them (and
6879  * the list may be modified in-place with replacement SVs in the latter
6880  * case).
6881  *
6882  * If the pattern hasn't changed from old_re, then old_re will be
6883  * returned.
6884  *
6885  * eng is the current engine. If that engine has an op_comp method, then
6886  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6887  * do the initial concatenation of arguments and pass on to the external
6888  * engine.
6889  *
6890  * If is_bare_re is not null, set it to a boolean indicating whether the
6891  * arg list reduced (after overloading) to a single bare regex which has
6892  * been returned (i.e. /$qr/).
6893  *
6894  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6895  *
6896  * pm_flags contains the PMf_* flags, typically based on those from the
6897  * pm_flags field of the related PMOP. Currently we're only interested in
6898  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6899  *
6900  * We can't allocate space until we know how big the compiled form will be,
6901  * but we can't compile it (and thus know how big it is) until we've got a
6902  * place to put the code.  So we cheat:  we compile it twice, once with code
6903  * generation turned off and size counting turned on, and once "for real".
6904  * This also means that we don't allocate space until we are sure that the
6905  * thing really will compile successfully, and we never have to move the
6906  * code and thus invalidate pointers into it.  (Note that it has to be in
6907  * one piece because free() must be able to free it all.) [NB: not true in perl]
6908  *
6909  * Beware that the optimization-preparation code in here knows about some
6910  * of the structure of the compiled regexp.  [I'll say.]
6911  */
6912
6913 REGEXP *
6914 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6915                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6916                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6917 {
6918     REGEXP *rx;
6919     struct regexp *r;
6920     regexp_internal *ri;
6921     STRLEN plen;
6922     char *exp;
6923     regnode *scan;
6924     I32 flags;
6925     SSize_t minlen = 0;
6926     U32 rx_flags;
6927     SV *pat;
6928     SV** new_patternp = patternp;
6929
6930     /* these are all flags - maybe they should be turned
6931      * into a single int with different bit masks */
6932     I32 sawlookahead = 0;
6933     I32 sawplus = 0;
6934     I32 sawopen = 0;
6935     I32 sawminmod = 0;
6936
6937     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6938     bool recompile = 0;
6939     bool runtime_code = 0;
6940     scan_data_t data;
6941     RExC_state_t RExC_state;
6942     RExC_state_t * const pRExC_state = &RExC_state;
6943 #ifdef TRIE_STUDY_OPT
6944     int restudied = 0;
6945     RExC_state_t copyRExC_state;
6946 #endif
6947     GET_RE_DEBUG_FLAGS_DECL;
6948
6949     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6950
6951     DEBUG_r(if (!PL_colorset) reginitcolors());
6952
6953     /* Initialize these here instead of as-needed, as is quick and avoids
6954      * having to test them each time otherwise */
6955     if (! PL_AboveLatin1) {
6956 #ifdef DEBUGGING
6957         char * dump_len_string;
6958 #endif
6959
6960         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6961         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6962         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6963         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6964         PL_HasMultiCharFold =
6965                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6966
6967         /* This is calculated here, because the Perl program that generates the
6968          * static global ones doesn't currently have access to
6969          * NUM_ANYOF_CODE_POINTS */
6970         PL_InBitmap = _new_invlist(2);
6971         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6972                                                     NUM_ANYOF_CODE_POINTS - 1);
6973 #ifdef DEBUGGING
6974         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6975         if (   ! dump_len_string
6976             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6977         {
6978             PL_dump_re_max_len = 60;    /* A reasonable default */
6979         }
6980 #endif
6981     }
6982
6983     pRExC_state->warn_text = NULL;
6984     pRExC_state->code_blocks = NULL;
6985
6986     if (is_bare_re)
6987         *is_bare_re = FALSE;
6988
6989     if (expr && (expr->op_type == OP_LIST ||
6990                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6991         /* allocate code_blocks if needed */
6992         OP *o;
6993         int ncode = 0;
6994
6995         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6996             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6997                 ncode++; /* count of DO blocks */
6998
6999         if (ncode)
7000             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
7001     }
7002
7003     if (!pat_count) {
7004         /* compile-time pattern with just OP_CONSTs and DO blocks */
7005
7006         int n;
7007         OP *o;
7008
7009         /* find how many CONSTs there are */
7010         assert(expr);
7011         n = 0;
7012         if (expr->op_type == OP_CONST)
7013             n = 1;
7014         else
7015             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7016                 if (o->op_type == OP_CONST)
7017                     n++;
7018             }
7019
7020         /* fake up an SV array */
7021
7022         assert(!new_patternp);
7023         Newx(new_patternp, n, SV*);
7024         SAVEFREEPV(new_patternp);
7025         pat_count = n;
7026
7027         n = 0;
7028         if (expr->op_type == OP_CONST)
7029             new_patternp[n] = cSVOPx_sv(expr);
7030         else
7031             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7032                 if (o->op_type == OP_CONST)
7033                     new_patternp[n++] = cSVOPo_sv;
7034             }
7035
7036     }
7037
7038     DEBUG_PARSE_r(Perl_re_printf( aTHX_
7039         "Assembling pattern from %d elements%s\n", pat_count,
7040             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7041
7042     /* set expr to the first arg op */
7043
7044     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
7045          && expr->op_type != OP_CONST)
7046     {
7047             expr = cLISTOPx(expr)->op_first;
7048             assert(   expr->op_type == OP_PUSHMARK
7049                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
7050                    || expr->op_type == OP_PADRANGE);
7051             expr = OpSIBLING(expr);
7052     }
7053
7054     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
7055                         expr, &recompile, NULL);
7056
7057     /* handle bare (possibly after overloading) regex: foo =~ $re */
7058     {
7059         SV *re = pat;
7060         if (SvROK(re))
7061             re = SvRV(re);
7062         if (SvTYPE(re) == SVt_REGEXP) {
7063             if (is_bare_re)
7064                 *is_bare_re = TRUE;
7065             SvREFCNT_inc(re);
7066             DEBUG_PARSE_r(Perl_re_printf( aTHX_
7067                 "Precompiled pattern%s\n",
7068                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7069
7070             return (REGEXP*)re;
7071         }
7072     }
7073
7074     exp = SvPV_nomg(pat, plen);
7075
7076     if (!eng->op_comp) {
7077         if ((SvUTF8(pat) && IN_BYTES)
7078                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
7079         {
7080             /* make a temporary copy; either to convert to bytes,
7081              * or to avoid repeating get-magic / overloaded stringify */
7082             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
7083                                         (IN_BYTES ? 0 : SvUTF8(pat)));
7084         }
7085         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
7086     }
7087
7088     /* ignore the utf8ness if the pattern is 0 length */
7089     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
7090
7091     RExC_uni_semantics = 0;
7092     RExC_seen_unfolded_sharp_s = 0;
7093     RExC_contains_locale = 0;
7094     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
7095     RExC_in_script_run = 0;
7096     RExC_study_started = 0;
7097     pRExC_state->runtime_code_qr = NULL;
7098     RExC_frame_head= NULL;
7099     RExC_frame_last= NULL;
7100     RExC_frame_count= 0;
7101
7102     DEBUG_r({
7103         RExC_mysv1= sv_newmortal();
7104         RExC_mysv2= sv_newmortal();
7105     });
7106     DEBUG_COMPILE_r({
7107             SV *dsv= sv_newmortal();
7108             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
7109             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
7110                           PL_colors[4],PL_colors[5],s);
7111         });
7112
7113   redo_first_pass:
7114     /* we jump here if we have to recompile, e.g., from upgrading the pattern
7115      * to utf8 */
7116
7117     if ((pm_flags & PMf_USE_RE_EVAL)
7118                 /* this second condition covers the non-regex literal case,
7119                  * i.e.  $foo =~ '(?{})'. */
7120                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
7121     )
7122         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
7123
7124     /* return old regex if pattern hasn't changed */
7125     /* XXX: note in the below we have to check the flags as well as the
7126      * pattern.
7127      *
7128      * Things get a touch tricky as we have to compare the utf8 flag
7129      * independently from the compile flags.  */
7130
7131     if (   old_re
7132         && !recompile
7133         && !!RX_UTF8(old_re) == !!RExC_utf8
7134         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7135         && RX_PRECOMP(old_re)
7136         && RX_PRELEN(old_re) == plen
7137         && memEQ(RX_PRECOMP(old_re), exp, plen)
7138         && !runtime_code /* with runtime code, always recompile */ )
7139     {
7140         return old_re;
7141     }
7142
7143     rx_flags = orig_rx_flags;
7144
7145     if (   initial_charset == REGEX_DEPENDS_CHARSET
7146         && (RExC_utf8 ||RExC_uni_semantics))
7147     {
7148
7149         /* Set to use unicode semantics if the pattern is in utf8 and has the
7150          * 'depends' charset specified, as it means unicode when utf8  */
7151         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7152     }
7153
7154     RExC_precomp = exp;
7155     RExC_precomp_adj = 0;
7156     RExC_flags = rx_flags;
7157     RExC_pm_flags = pm_flags;
7158
7159     if (runtime_code) {
7160         assert(TAINTING_get || !TAINT_get);
7161         if (TAINT_get)
7162             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7163
7164         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7165             /* whoops, we have a non-utf8 pattern, whilst run-time code
7166              * got compiled as utf8. Try again with a utf8 pattern */
7167             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7168                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7169             goto redo_first_pass;
7170         }
7171     }
7172     assert(!pRExC_state->runtime_code_qr);
7173
7174     RExC_sawback = 0;
7175
7176     RExC_seen = 0;
7177     RExC_maxlen = 0;
7178     RExC_in_lookbehind = 0;
7179     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7180     RExC_extralen = 0;
7181 #ifdef EBCDIC
7182     RExC_recode_x_to_native = 0;
7183 #endif
7184     RExC_in_multi_char_class = 0;
7185
7186     /* First pass: determine size, legality. */
7187     RExC_parse = exp;
7188     RExC_start = RExC_adjusted_start = exp;
7189     RExC_end = exp + plen;
7190     RExC_precomp_end = RExC_end;
7191     RExC_naughty = 0;
7192     RExC_npar = 1;
7193     RExC_nestroot = 0;
7194     RExC_size = 0L;
7195     RExC_emit = (regnode *) &RExC_emit_dummy;
7196     RExC_whilem_seen = 0;
7197     RExC_open_parens = NULL;
7198     RExC_close_parens = NULL;
7199     RExC_end_op = NULL;
7200     RExC_paren_names = NULL;
7201 #ifdef DEBUGGING
7202     RExC_paren_name_list = NULL;
7203 #endif
7204     RExC_recurse = NULL;
7205     RExC_study_chunk_recursed = NULL;
7206     RExC_study_chunk_recursed_bytes= 0;
7207     RExC_recurse_count = 0;
7208     pRExC_state->code_index = 0;
7209
7210     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7211      * code makes sure the final byte is an uncounted NUL.  But should this
7212      * ever not be the case, lots of things could read beyond the end of the
7213      * buffer: loops like
7214      *      while(isFOO(*RExC_parse)) RExC_parse++;
7215      *      strchr(RExC_parse, "foo");
7216      * etc.  So it is worth noting. */
7217     assert(*RExC_end == '\0');
7218
7219     DEBUG_PARSE_r(
7220         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7221         RExC_lastnum=0;
7222         RExC_lastparse=NULL;
7223     );
7224
7225     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7226         /* It's possible to write a regexp in ascii that represents Unicode
7227         codepoints outside of the byte range, such as via \x{100}. If we
7228         detect such a sequence we have to convert the entire pattern to utf8
7229         and then recompile, as our sizing calculation will have been based
7230         on 1 byte == 1 character, but we will need to use utf8 to encode
7231         at least some part of the pattern, and therefore must convert the whole
7232         thing.
7233         -- dmq */
7234         if (MUST_RESTART(flags)) {
7235             if (flags & NEED_UTF8) {
7236                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7237                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7238                 DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo pass 1 after upgrade\n"));
7239             }
7240             else {
7241                 DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo pass 1\n"));
7242             }
7243
7244             goto redo_first_pass;
7245         }
7246         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
7247     }
7248
7249     DEBUG_PARSE_r({
7250         Perl_re_printf( aTHX_
7251             "Required size %" IVdf " nodes\n"
7252             "Starting second pass (creation)\n",
7253             (IV)RExC_size);
7254         RExC_lastnum=0;
7255         RExC_lastparse=NULL;
7256     });
7257
7258     /* The first pass could have found things that force Unicode semantics */
7259     if ((RExC_utf8 || RExC_uni_semantics)
7260          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7261     {
7262         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7263     }
7264
7265     /* Small enough for pointer-storage convention?
7266        If extralen==0, this means that we will not need long jumps. */
7267     if (RExC_size >= 0x10000L && RExC_extralen)
7268         RExC_size += RExC_extralen;
7269     else
7270         RExC_extralen = 0;
7271     if (RExC_whilem_seen > 15)
7272         RExC_whilem_seen = 15;
7273
7274     /* Allocate space and zero-initialize. Note, the two step process
7275        of zeroing when in debug mode, thus anything assigned has to
7276        happen after that */
7277     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7278     r = ReANY(rx);
7279     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7280          char, regexp_internal);
7281     if ( r == NULL || ri == NULL )
7282         FAIL("Regexp out of space");
7283 #ifdef DEBUGGING
7284     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7285     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7286          char);
7287 #else
7288     /* bulk initialize base fields with 0. */
7289     Zero(ri, sizeof(regexp_internal), char);
7290 #endif
7291
7292     /* non-zero initialization begins here */
7293     RXi_SET( r, ri );
7294     r->engine= eng;
7295     r->extflags = rx_flags;
7296     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7297
7298     if (pm_flags & PMf_IS_QR) {
7299         ri->code_blocks = pRExC_state->code_blocks;
7300         if (ri->code_blocks)
7301             ri->code_blocks->refcnt++;
7302     }
7303
7304     {
7305         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7306         bool has_charset = (get_regex_charset(r->extflags)
7307                                                     != REGEX_DEPENDS_CHARSET);
7308
7309         /* The caret is output if there are any defaults: if not all the STD
7310          * flags are set, or if no character set specifier is needed */
7311         bool has_default =
7312                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7313                     || ! has_charset);
7314         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7315                                                    == REG_RUN_ON_COMMENT_SEEN);
7316         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7317                             >> RXf_PMf_STD_PMMOD_SHIFT);
7318         const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7319         char *p;
7320
7321         /* We output all the necessary flags; we never output a minus, as all
7322          * those are defaults, so are
7323          * covered by the caret */
7324         const STRLEN wraplen = plen + has_p + has_runon
7325             + has_default       /* If needs a caret */
7326             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7327
7328                 /* If needs a character set specifier */
7329             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7330             + (sizeof("(?:)") - 1);
7331
7332         /* make sure PL_bitcount bounds not exceeded */
7333         assert(sizeof(STD_PAT_MODS) <= 8);
7334
7335         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
7336         SvPOK_on(rx);
7337         if (RExC_utf8)
7338             SvFLAGS(rx) |= SVf_UTF8;
7339         *p++='('; *p++='?';
7340
7341         /* If a default, cover it using the caret */
7342         if (has_default) {
7343             *p++= DEFAULT_PAT_MOD;
7344         }
7345         if (has_charset) {
7346             STRLEN len;
7347             const char* const name = get_regex_charset_name(r->extflags, &len);
7348             Copy(name, p, len, char);
7349             p += len;
7350         }
7351         if (has_p)
7352             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7353         {
7354             char ch;
7355             while((ch = *fptr++)) {
7356                 if(reganch & 1)
7357                     *p++ = ch;
7358                 reganch >>= 1;
7359             }
7360         }
7361
7362         *p++ = ':';
7363         Copy(RExC_precomp, p, plen, char);
7364         assert ((RX_WRAPPED(rx) - p) < 16);
7365         r->pre_prefix = p - RX_WRAPPED(rx);
7366         p += plen;
7367         if (has_runon)
7368             *p++ = '\n';
7369         *p++ = ')';
7370         *p = 0;
7371         SvCUR_set(rx, p - RX_WRAPPED(rx));
7372     }
7373
7374     r->intflags = 0;
7375     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7376
7377     /* Useful during FAIL. */
7378 #ifdef RE_TRACK_PATTERN_OFFSETS
7379     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7380     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7381                           "%s %" UVuf " bytes for offset annotations.\n",
7382                           ri->u.offsets ? "Got" : "Couldn't get",
7383                           (UV)((2*RExC_size+1) * sizeof(U32))));
7384 #endif
7385     SetProgLen(ri,RExC_size);
7386     RExC_rx_sv = rx;
7387     RExC_rx = r;
7388     RExC_rxi = ri;
7389
7390     /* Second pass: emit code. */
7391     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7392     RExC_pm_flags = pm_flags;
7393     RExC_parse = exp;
7394     RExC_end = exp + plen;
7395     RExC_naughty = 0;
7396     RExC_emit_start = ri->program;
7397     RExC_emit = ri->program;
7398     RExC_emit_bound = ri->program + RExC_size + 1;
7399     pRExC_state->code_index = 0;
7400
7401     *((char*) RExC_emit++) = (char) REG_MAGIC;
7402     /* setup various meta data about recursion, this all requires
7403      * RExC_npar to be correctly set, and a bit later on we clear it */
7404     if (RExC_seen & REG_RECURSE_SEEN) {
7405         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7406             "%*s%*s Setting up open/close parens\n",
7407                   22, "|    |", (int)(0 * 2 + 1), ""));
7408
7409         /* setup RExC_open_parens, which holds the address of each
7410          * OPEN tag, and to make things simpler for the 0 index
7411          * the start of the program - this is used later for offsets */
7412         Newxz(RExC_open_parens, RExC_npar,regnode *);
7413         SAVEFREEPV(RExC_open_parens);
7414         RExC_open_parens[0] = RExC_emit;
7415
7416         /* setup RExC_close_parens, which holds the address of each
7417          * CLOSE tag, and to make things simpler for the 0 index
7418          * the end of the program - this is used later for offsets */
7419         Newxz(RExC_close_parens, RExC_npar,regnode *);
7420         SAVEFREEPV(RExC_close_parens);
7421         /* we dont know where end op starts yet, so we dont
7422          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7423
7424         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7425          * So its 1 if there are no parens. */
7426         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7427                                          ((RExC_npar & 0x07) != 0);
7428         Newx(RExC_study_chunk_recursed,
7429              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7430         SAVEFREEPV(RExC_study_chunk_recursed);
7431     }
7432     RExC_npar = 1;
7433     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7434         ReREFCNT_dec(rx);
7435         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#" UVxf, (UV) flags);
7436     }
7437     DEBUG_OPTIMISE_r(
7438         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7439     );
7440
7441     /* XXXX To minimize changes to RE engine we always allocate
7442        3-units-long substrs field. */
7443     Newx(r->substrs, 1, struct reg_substr_data);
7444     if (RExC_recurse_count) {
7445         Newx(RExC_recurse,RExC_recurse_count,regnode *);
7446         SAVEFREEPV(RExC_recurse);
7447     }
7448
7449   reStudy:
7450     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7451     DEBUG_r(
7452         RExC_study_chunk_recursed_count= 0;
7453     );
7454     Zero(r->substrs, 1, struct reg_substr_data);
7455     if (RExC_study_chunk_recursed) {
7456         Zero(RExC_study_chunk_recursed,
7457              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7458     }
7459
7460
7461 #ifdef TRIE_STUDY_OPT
7462     if (!restudied) {
7463         StructCopy(&zero_scan_data, &data, scan_data_t);
7464         copyRExC_state = RExC_state;
7465     } else {
7466         U32 seen=RExC_seen;
7467         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7468
7469         RExC_state = copyRExC_state;
7470         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7471             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7472         else
7473             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7474         StructCopy(&zero_scan_data, &data, scan_data_t);
7475     }
7476 #else
7477     StructCopy(&zero_scan_data, &data, scan_data_t);
7478 #endif
7479
7480     /* Dig out information for optimizations. */
7481     r->extflags = RExC_flags; /* was pm_op */
7482     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7483
7484     if (UTF)
7485         SvUTF8_on(rx);  /* Unicode in it? */
7486     ri->regstclass = NULL;
7487     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7488         r->intflags |= PREGf_NAUGHTY;
7489     scan = ri->program + 1;             /* First BRANCH. */
7490
7491     /* testing for BRANCH here tells us whether there is "must appear"
7492        data in the pattern. If there is then we can use it for optimisations */
7493     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7494                                                   */
7495         SSize_t fake;
7496         STRLEN longest_length[2];
7497         regnode_ssc ch_class; /* pointed to by data */
7498         int stclass_flag;
7499         SSize_t last_close = 0; /* pointed to by data */
7500         regnode *first= scan;
7501         regnode *first_next= regnext(first);
7502         int i;
7503
7504         /*
7505          * Skip introductions and multiplicators >= 1
7506          * so that we can extract the 'meat' of the pattern that must
7507          * match in the large if() sequence following.
7508          * NOTE that EXACT is NOT covered here, as it is normally
7509          * picked up by the optimiser separately.
7510          *
7511          * This is unfortunate as the optimiser isnt handling lookahead
7512          * properly currently.
7513          *
7514          */
7515         while ((OP(first) == OPEN && (sawopen = 1)) ||
7516                /* An OR of *one* alternative - should not happen now. */
7517             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7518             /* for now we can't handle lookbehind IFMATCH*/
7519             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7520             (OP(first) == PLUS) ||
7521             (OP(first) == MINMOD) ||
7522                /* An {n,m} with n>0 */
7523             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7524             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7525         {
7526                 /*
7527                  * the only op that could be a regnode is PLUS, all the rest
7528                  * will be regnode_1 or regnode_2.
7529                  *
7530                  * (yves doesn't think this is true)
7531                  */
7532                 if (OP(first) == PLUS)
7533                     sawplus = 1;
7534                 else {
7535                     if (OP(first) == MINMOD)
7536                         sawminmod = 1;
7537                     first += regarglen[OP(first)];
7538                 }
7539                 first = NEXTOPER(first);
7540                 first_next= regnext(first);
7541         }
7542
7543         /* Starting-point info. */
7544       again:
7545         DEBUG_PEEP("first:", first, 0, 0);
7546         /* Ignore EXACT as we deal with it later. */
7547         if (PL_regkind[OP(first)] == EXACT) {
7548             if (OP(first) == EXACT || OP(first) == EXACTL)
7549                 NOOP;   /* Empty, get anchored substr later. */
7550             else
7551                 ri->regstclass = first;
7552         }
7553 #ifdef TRIE_STCLASS
7554         else if (PL_regkind[OP(first)] == TRIE &&
7555                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7556         {
7557             /* this can happen only on restudy */
7558             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7559         }
7560 #endif
7561         else if (REGNODE_SIMPLE(OP(first)))
7562             ri->regstclass = first;
7563         else if (PL_regkind[OP(first)] == BOUND ||
7564                  PL_regkind[OP(first)] == NBOUND)
7565             ri->regstclass = first;
7566         else if (PL_regkind[OP(first)] == BOL) {
7567             r->intflags |= (OP(first) == MBOL
7568                            ? PREGf_ANCH_MBOL
7569                            : PREGf_ANCH_SBOL);
7570             first = NEXTOPER(first);
7571             goto again;
7572         }
7573         else if (OP(first) == GPOS) {
7574             r->intflags |= PREGf_ANCH_GPOS;
7575             first = NEXTOPER(first);
7576             goto again;
7577         }
7578         else if ((!sawopen || !RExC_sawback) &&
7579             !sawlookahead &&
7580             (OP(first) == STAR &&
7581             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7582             !(r->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
7583         {
7584             /* turn .* into ^.* with an implied $*=1 */
7585             const int type =
7586                 (OP(NEXTOPER(first)) == REG_ANY)
7587                     ? PREGf_ANCH_MBOL
7588                     : PREGf_ANCH_SBOL;
7589             r->intflags |= (type | PREGf_IMPLICIT);
7590             first = NEXTOPER(first);
7591             goto again;
7592         }
7593         if (sawplus && !sawminmod && !sawlookahead
7594             && (!sawopen || !RExC_sawback)
7595             && !pRExC_state->code_blocks) /* May examine pos and $& */
7596             /* x+ must match at the 1st pos of run of x's */
7597             r->intflags |= PREGf_SKIP;
7598
7599         /* Scan is after the zeroth branch, first is atomic matcher. */
7600 #ifdef TRIE_STUDY_OPT
7601         DEBUG_PARSE_r(
7602             if (!restudied)
7603                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7604                               (IV)(first - scan + 1))
7605         );
7606 #else
7607         DEBUG_PARSE_r(
7608             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7609                 (IV)(first - scan + 1))
7610         );
7611 #endif
7612
7613
7614         /*
7615         * If there's something expensive in the r.e., find the
7616         * longest literal string that must appear and make it the
7617         * regmust.  Resolve ties in favor of later strings, since
7618         * the regstart check works with the beginning of the r.e.
7619         * and avoiding duplication strengthens checking.  Not a
7620         * strong reason, but sufficient in the absence of others.
7621         * [Now we resolve ties in favor of the earlier string if
7622         * it happens that c_offset_min has been invalidated, since the
7623         * earlier string may buy us something the later one won't.]
7624         */
7625
7626         data.substrs[0].str = newSVpvs("");
7627         data.substrs[1].str = newSVpvs("");
7628         data.last_found = newSVpvs("");
7629         data.cur_is_floating = 0; /* initially any found substring is fixed */
7630         ENTER_with_name("study_chunk");
7631         SAVEFREESV(data.substrs[0].str);
7632         SAVEFREESV(data.substrs[1].str);
7633         SAVEFREESV(data.last_found);
7634         first = scan;
7635         if (!ri->regstclass) {
7636             ssc_init(pRExC_state, &ch_class);
7637             data.start_class = &ch_class;
7638             stclass_flag = SCF_DO_STCLASS_AND;
7639         } else                          /* XXXX Check for BOUND? */
7640             stclass_flag = 0;
7641         data.last_closep = &last_close;
7642
7643         DEBUG_RExC_seen();
7644         /*
7645          * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/
7646          * (NO top level branches)
7647          */
7648         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7649                              scan + RExC_size, /* Up to end */
7650             &data, -1, 0, NULL,
7651             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7652                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7653             0);
7654
7655
7656         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7657
7658
7659         if ( RExC_npar == 1 && !data.cur_is_floating
7660              && data.last_start_min == 0 && data.last_end > 0
7661              && !RExC_seen_zerolen
7662              && !(RExC_seen & REG_VERBARG_SEEN)
7663              && !(RExC_seen & REG_GPOS_SEEN)
7664         ){
7665             r->extflags |= RXf_CHECK_ALL;
7666         }
7667         scan_commit(pRExC_state, &data,&minlen,0);
7668
7669
7670         /* XXX this is done in reverse order because that's the way the
7671          * code was before it was parameterised. Don't know whether it
7672          * actually needs doing in reverse order. DAPM */
7673         for (i = 1; i >= 0; i--) {
7674             longest_length[i] = CHR_SVLEN(data.substrs[i].str);
7675
7676             if (   !(   i
7677                      && SvCUR(data.substrs[0].str)  /* ok to leave SvCUR */
7678                      &&    data.substrs[0].min_offset
7679                         == data.substrs[1].min_offset
7680                      &&    SvCUR(data.substrs[0].str)
7681                         == SvCUR(data.substrs[1].str)
7682                     )
7683                 && S_setup_longest (aTHX_ pRExC_state,
7684                                         &(r->substrs->data[i]),
7685                                         &(data.substrs[i]),
7686                                         longest_length[i]))
7687             {
7688                 r->substrs->data[i].min_offset =
7689                         data.substrs[i].min_offset - data.substrs[i].lookbehind;
7690
7691                 r->substrs->data[i].max_offset = data.substrs[i].max_offset;
7692                 /* Don't offset infinity */
7693                 if (data.substrs[i].max_offset < SSize_t_MAX)
7694                     r->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
7695                 SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
7696             }
7697             else {
7698                 r->substrs->data[i].substr      = NULL;
7699                 r->substrs->data[i].utf8_substr = NULL;
7700                 longest_length[i] = 0;
7701             }
7702         }
7703
7704         LEAVE_with_name("study_chunk");
7705
7706         if (ri->regstclass
7707             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7708             ri->regstclass = NULL;
7709
7710         if ((!(r->substrs->data[0].substr || r->substrs->data[0].utf8_substr)
7711               || r->substrs->data[0].min_offset)
7712             && stclass_flag
7713             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7714             && is_ssc_worth_it(pRExC_state, data.start_class))
7715         {
7716             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7717
7718             ssc_finalize(pRExC_state, data.start_class);
7719
7720             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7721             StructCopy(data.start_class,
7722                        (regnode_ssc*)RExC_rxi->data->data[n],
7723                        regnode_ssc);
7724             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7725             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7726             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7727                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7728                       Perl_re_printf( aTHX_
7729                                     "synthetic stclass \"%s\".\n",
7730                                     SvPVX_const(sv));});
7731             data.start_class = NULL;
7732         }
7733
7734         /* A temporary algorithm prefers floated substr to fixed one of
7735          * same length to dig more info. */
7736         i = (longest_length[0] <= longest_length[1]);
7737         r->substrs->check_ix = i;
7738         r->check_end_shift  = r->substrs->data[i].end_shift;
7739         r->check_substr     = r->substrs->data[i].substr;
7740         r->check_utf8       = r->substrs->data[i].utf8_substr;
7741         r->check_offset_min = r->substrs->data[i].min_offset;
7742         r->check_offset_max = r->substrs->data[i].max_offset;
7743         if (!i && (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
7744             r->intflags |= PREGf_NOSCAN;
7745
7746         if ((r->check_substr || r->check_utf8) ) {
7747             r->extflags |= RXf_USE_INTUIT;
7748             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7749                 r->extflags |= RXf_INTUIT_TAIL;
7750         }
7751
7752         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7753         if ( (STRLEN)minlen < longest_length[1] )
7754             minlen= longest_length[1];
7755         if ( (STRLEN)minlen < longest_length[0] )
7756             minlen= longest_length[0];
7757         */
7758     }
7759     else {
7760         /* Several toplevels. Best we can is to set minlen. */
7761         SSize_t fake;
7762         regnode_ssc ch_class;
7763         SSize_t last_close = 0;
7764
7765         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7766
7767         scan = ri->program + 1;
7768         ssc_init(pRExC_state, &ch_class);
7769         data.start_class = &ch_class;
7770         data.last_closep = &last_close;
7771
7772         DEBUG_RExC_seen();
7773         /*
7774          * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../
7775          * (patterns WITH top level branches)
7776          */
7777         minlen = study_chunk(pRExC_state,
7778             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7779             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7780                                                       ? SCF_TRIE_DOING_RESTUDY
7781                                                       : 0),
7782             0);
7783
7784         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7785
7786         r->check_substr = NULL;
7787         r->check_utf8 = NULL;
7788         r->substrs->data[0].substr      = NULL;
7789         r->substrs->data[0].utf8_substr = NULL;
7790         r->substrs->data[1].substr      = NULL;
7791         r->substrs->data[1].utf8_substr = NULL;
7792
7793         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7794             && is_ssc_worth_it(pRExC_state, data.start_class))
7795         {
7796             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7797
7798             ssc_finalize(pRExC_state, data.start_class);
7799
7800             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7801             StructCopy(data.start_class,
7802                        (regnode_ssc*)RExC_rxi->data->data[n],
7803                        regnode_ssc);
7804             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7805             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7806             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7807                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7808                       Perl_re_printf( aTHX_
7809                                     "synthetic stclass \"%s\".\n",
7810                                     SvPVX_const(sv));});
7811             data.start_class = NULL;
7812         }
7813     }
7814
7815     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7816         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7817         r->maxlen = REG_INFTY;
7818     }
7819     else {
7820         r->maxlen = RExC_maxlen;
7821     }
7822
7823     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7824        the "real" pattern. */
7825     DEBUG_OPTIMISE_r({
7826         Perl_re_printf( aTHX_ "minlen: %" IVdf " r->minlen:%" IVdf " maxlen:%" IVdf "\n",
7827                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7828     });
7829     r->minlenret = minlen;
7830     if (r->minlen < minlen)
7831         r->minlen = minlen;
7832
7833     if (RExC_seen & REG_RECURSE_SEEN ) {
7834         r->intflags |= PREGf_RECURSE_SEEN;
7835         Newx(r->recurse_locinput, r->nparens + 1, char *);
7836     }
7837     if (RExC_seen & REG_GPOS_SEEN)
7838         r->intflags |= PREGf_GPOS_SEEN;
7839     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7840         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7841                                                 lookbehind */
7842     if (pRExC_state->code_blocks)
7843         r->extflags |= RXf_EVAL_SEEN;
7844     if (RExC_seen & REG_VERBARG_SEEN)
7845     {
7846         r->intflags |= PREGf_VERBARG_SEEN;
7847         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7848     }
7849     if (RExC_seen & REG_CUTGROUP_SEEN)
7850         r->intflags |= PREGf_CUTGROUP_SEEN;
7851     if (pm_flags & PMf_USE_RE_EVAL)
7852         r->intflags |= PREGf_USE_RE_EVAL;
7853     if (RExC_paren_names)
7854         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7855     else
7856         RXp_PAREN_NAMES(r) = NULL;
7857
7858     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7859      * so it can be used in pp.c */
7860     if (r->intflags & PREGf_ANCH)
7861         r->extflags |= RXf_IS_ANCHORED;
7862
7863
7864     {
7865         /* this is used to identify "special" patterns that might result
7866          * in Perl NOT calling the regex engine and instead doing the match "itself",
7867          * particularly special cases in split//. By having the regex compiler
7868          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7869          * we avoid weird issues with equivalent patterns resulting in different behavior,
7870          * AND we allow non Perl engines to get the same optimizations by the setting the
7871          * flags appropriately - Yves */
7872         regnode *first = ri->program + 1;
7873         U8 fop = OP(first);
7874         regnode *next = regnext(first);
7875         U8 nop = OP(next);
7876
7877         if (PL_regkind[fop] == NOTHING && nop == END)
7878             r->extflags |= RXf_NULL;
7879         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7880             /* when fop is SBOL first->flags will be true only when it was
7881              * produced by parsing /\A/, and not when parsing /^/. This is
7882              * very important for the split code as there we want to
7883              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7884              * See rt #122761 for more details. -- Yves */
7885             r->extflags |= RXf_START_ONLY;
7886         else if (fop == PLUS
7887                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7888                  && nop == END)
7889             r->extflags |= RXf_WHITE;
7890         else if ( r->extflags & RXf_SPLIT
7891                   && (fop == EXACT || fop == EXACTL)
7892                   && STR_LEN(first) == 1
7893                   && *(STRING(first)) == ' '
7894                   && nop == END )
7895             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7896
7897     }
7898
7899     if (RExC_contains_locale) {
7900         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7901     }
7902
7903 #ifdef DEBUGGING
7904     if (RExC_paren_names) {
7905         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7906         ri->data->data[ri->name_list_idx]
7907                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7908     } else
7909 #endif
7910     ri->name_list_idx = 0;
7911
7912     while ( RExC_recurse_count > 0 ) {
7913         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7914         /*
7915          * This data structure is set up in study_chunk() and is used
7916          * to calculate the distance between a GOSUB regopcode and
7917          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
7918          * it refers to.
7919          *
7920          * If for some reason someone writes code that optimises
7921          * away a GOSUB opcode then the assert should be changed to
7922          * an if(scan) to guard the ARG2L_SET() - Yves
7923          *
7924          */
7925         assert(scan && OP(scan) == GOSUB);
7926         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7927     }
7928
7929     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7930     /* assume we don't need to swap parens around before we match */
7931     DEBUG_TEST_r({
7932         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7933             (unsigned long)RExC_study_chunk_recursed_count);
7934     });
7935     DEBUG_DUMP_r({
7936         DEBUG_RExC_seen();
7937         Perl_re_printf( aTHX_ "Final program:\n");
7938         regdump(r);
7939     });
7940 #ifdef RE_TRACK_PATTERN_OFFSETS
7941     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7942         const STRLEN len = ri->u.offsets[0];
7943         STRLEN i;
7944         GET_RE_DEBUG_FLAGS_DECL;
7945         Perl_re_printf( aTHX_
7946                       "Offsets: [%" UVuf "]\n\t", (UV)ri->u.offsets[0]);
7947         for (i = 1; i <= len; i++) {
7948             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7949                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7950                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7951             }
7952         Perl_re_printf( aTHX_  "\n");
7953     });
7954 #endif
7955
7956 #ifdef USE_ITHREADS
7957     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7958      * by setting the regexp SV to readonly-only instead. If the
7959      * pattern's been recompiled, the USEDness should remain. */
7960     if (old_re && SvREADONLY(old_re))
7961         SvREADONLY_on(rx);
7962 #endif
7963     return rx;
7964 }
7965
7966
7967 SV*
7968 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7969                     const U32 flags)
7970 {
7971     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7972
7973     PERL_UNUSED_ARG(value);
7974
7975     if (flags & RXapif_FETCH) {
7976         return reg_named_buff_fetch(rx, key, flags);
7977     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7978         Perl_croak_no_modify();
7979         return NULL;
7980     } else if (flags & RXapif_EXISTS) {
7981         return reg_named_buff_exists(rx, key, flags)
7982             ? &PL_sv_yes
7983             : &PL_sv_no;
7984     } else if (flags & RXapif_REGNAMES) {
7985         return reg_named_buff_all(rx, flags);
7986     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7987         return reg_named_buff_scalar(rx, flags);
7988     } else {
7989         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7990         return NULL;
7991     }
7992 }
7993
7994 SV*
7995 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7996                          const U32 flags)
7997 {
7998     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7999     PERL_UNUSED_ARG(lastkey);
8000
8001     if (flags & RXapif_FIRSTKEY)
8002         return reg_named_buff_firstkey(rx, flags);
8003     else if (flags & RXapif_NEXTKEY)
8004         return reg_named_buff_nextkey(rx, flags);
8005     else {
8006         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
8007                                             (int)flags);
8008         return NULL;
8009     }
8010 }
8011
8012 SV*
8013 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
8014                           const U32 flags)
8015 {
8016     SV *ret;
8017     struct regexp *const rx = ReANY(r);
8018
8019     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
8020
8021     if (rx && RXp_PAREN_NAMES(rx)) {
8022         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
8023         if (he_str) {
8024             IV i;
8025             SV* sv_dat=HeVAL(he_str);
8026             I32 *nums=(I32*)SvPVX(sv_dat);
8027             AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
8028             for ( i=0; i<SvIVX(sv_dat); i++ ) {
8029                 if ((I32)(rx->nparens) >= nums[i]
8030                     && rx->offs[nums[i]].start != -1
8031                     && rx->offs[nums[i]].end != -1)
8032                 {
8033                     ret = newSVpvs("");
8034                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
8035                     if (!retarray)
8036                         return ret;
8037                 } else {
8038                     if (retarray)
8039                         ret = newSVsv(&PL_sv_undef);
8040                 }
8041                 if (retarray)
8042                     av_push(retarray, ret);
8043             }
8044             if (retarray)
8045                 return newRV_noinc(MUTABLE_SV(retarray));
8046         }
8047     }
8048     return NULL;
8049 }
8050
8051 bool
8052 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
8053                            const U32 flags)
8054 {
8055     struct regexp *const rx = ReANY(r);
8056
8057     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
8058
8059     if (rx && RXp_PAREN_NAMES(rx)) {
8060         if (flags & RXapif_ALL) {
8061             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
8062         } else {
8063             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
8064             if (sv) {
8065                 SvREFCNT_dec_NN(sv);
8066                 return TRUE;
8067             } else {
8068                 return FALSE;
8069             }
8070         }
8071     } else {
8072         return FALSE;
8073     }
8074 }
8075
8076 SV*
8077 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
8078 {
8079     struct regexp *const rx = ReANY(r);
8080
8081     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
8082
8083     if ( rx && RXp_PAREN_NAMES(rx) ) {
8084         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
8085
8086         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
8087     } else {
8088         return FALSE;
8089     }
8090 }
8091
8092 SV*
8093 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
8094 {
8095     struct regexp *const rx = ReANY(r);
8096     GET_RE_DEBUG_FLAGS_DECL;
8097
8098     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
8099
8100     if (rx && RXp_PAREN_NAMES(rx)) {
8101         HV *hv = RXp_PAREN_NAMES(rx);
8102         HE *temphe;
8103         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8104             IV i;
8105             IV parno = 0;
8106             SV* sv_dat = HeVAL(temphe);
8107             I32 *nums = (I32*)SvPVX(sv_dat);
8108             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8109                 if ((I32)(rx->lastparen) >= nums[i] &&
8110                     rx->offs[nums[i]].start != -1 &&
8111                     rx->offs[nums[i]].end != -1)
8112                 {
8113                     parno = nums[i];
8114                     break;
8115                 }
8116             }
8117             if (parno || flags & RXapif_ALL) {
8118                 return newSVhek(HeKEY_hek(temphe));
8119             }
8120         }
8121     }
8122     return NULL;
8123 }
8124
8125 SV*
8126 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8127 {
8128     SV *ret;
8129     AV *av;
8130     SSize_t length;
8131     struct regexp *const rx = ReANY(r);
8132
8133     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8134
8135     if (rx && RXp_PAREN_NAMES(rx)) {
8136         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8137             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8138         } else if (flags & RXapif_ONE) {
8139             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8140             av = MUTABLE_AV(SvRV(ret));
8141             length = av_tindex(av);
8142             SvREFCNT_dec_NN(ret);
8143             return newSViv(length + 1);
8144         } else {
8145             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8146                                                 (int)flags);
8147             return NULL;
8148         }
8149     }
8150     return &PL_sv_undef;
8151 }
8152
8153 SV*
8154 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8155 {
8156     struct regexp *const rx = ReANY(r);
8157     AV *av = newAV();
8158
8159     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8160
8161     if (rx && RXp_PAREN_NAMES(rx)) {
8162         HV *hv= RXp_PAREN_NAMES(rx);
8163         HE *temphe;
8164         (void)hv_iterinit(hv);
8165         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8166             IV i;
8167             IV parno = 0;
8168             SV* sv_dat = HeVAL(temphe);
8169             I32 *nums = (I32*)SvPVX(sv_dat);
8170             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8171                 if ((I32)(rx->lastparen) >= nums[i] &&
8172                     rx->offs[nums[i]].start != -1 &&
8173                     rx->offs[nums[i]].end != -1)
8174                 {
8175                     parno = nums[i];
8176                     break;
8177                 }
8178             }
8179             if (parno || flags & RXapif_ALL) {
8180                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8181             }
8182         }
8183     }
8184
8185     return newRV_noinc(MUTABLE_SV(av));
8186 }
8187
8188 void
8189 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8190                              SV * const sv)
8191 {
8192     struct regexp *const rx = ReANY(r);
8193     char *s = NULL;
8194     SSize_t i = 0;
8195     SSize_t s1, t1;
8196     I32 n = paren;
8197
8198     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8199
8200     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8201            || n == RX_BUFF_IDX_CARET_FULLMATCH
8202            || n == RX_BUFF_IDX_CARET_POSTMATCH
8203        )
8204     {
8205         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8206         if (!keepcopy) {
8207             /* on something like
8208              *    $r = qr/.../;
8209              *    /$qr/p;
8210              * the KEEPCOPY is set on the PMOP rather than the regex */
8211             if (PL_curpm && r == PM_GETRE(PL_curpm))
8212                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8213         }
8214         if (!keepcopy)
8215             goto ret_undef;
8216     }
8217
8218     if (!rx->subbeg)
8219         goto ret_undef;
8220
8221     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8222         /* no need to distinguish between them any more */
8223         n = RX_BUFF_IDX_FULLMATCH;
8224
8225     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8226         && rx->offs[0].start != -1)
8227     {
8228         /* $`, ${^PREMATCH} */
8229         i = rx->offs[0].start;
8230         s = rx->subbeg;
8231     }
8232     else
8233     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8234         && rx->offs[0].end != -1)
8235     {
8236         /* $', ${^POSTMATCH} */
8237         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8238         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8239     }
8240     else
8241     if ( 0 <= n && n <= (I32)rx->nparens &&
8242         (s1 = rx->offs[n].start) != -1 &&
8243         (t1 = rx->offs[n].end) != -1)
8244     {
8245         /* $&, ${^MATCH},  $1 ... */
8246         i = t1 - s1;
8247         s = rx->subbeg + s1 - rx->suboffset;
8248     } else {
8249         goto ret_undef;
8250     }
8251
8252     assert(s >= rx->subbeg);
8253     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8254     if (i >= 0) {
8255 #ifdef NO_TAINT_SUPPORT
8256         sv_setpvn(sv, s, i);
8257 #else
8258         const int oldtainted = TAINT_get;
8259         TAINT_NOT;
8260         sv_setpvn(sv, s, i);
8261         TAINT_set(oldtainted);
8262 #endif
8263         if (RXp_MATCH_UTF8(rx))
8264             SvUTF8_on(sv);
8265         else
8266             SvUTF8_off(sv);
8267         if (TAINTING_get) {
8268             if (RXp_MATCH_TAINTED(rx)) {
8269                 if (SvTYPE(sv) >= SVt_PVMG) {
8270                     MAGIC* const mg = SvMAGIC(sv);
8271                     MAGIC* mgt;
8272                     TAINT;
8273                     SvMAGIC_set(sv, mg->mg_moremagic);
8274                     SvTAINT(sv);
8275                     if ((mgt = SvMAGIC(sv))) {
8276                         mg->mg_moremagic = mgt;
8277                         SvMAGIC_set(sv, mg);
8278                     }
8279                 } else {
8280                     TAINT;
8281                     SvTAINT(sv);
8282                 }
8283             } else
8284                 SvTAINTED_off(sv);
8285         }
8286     } else {
8287       ret_undef:
8288         sv_set_undef(sv);
8289         return;
8290     }
8291 }
8292
8293 void
8294 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8295                                                          SV const * const value)
8296 {
8297     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8298
8299     PERL_UNUSED_ARG(rx);
8300     PERL_UNUSED_ARG(paren);
8301     PERL_UNUSED_ARG(value);
8302
8303     if (!PL_localizing)
8304         Perl_croak_no_modify();
8305 }
8306
8307 I32
8308 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8309                               const I32 paren)
8310 {
8311     struct regexp *const rx = ReANY(r);
8312     I32 i;
8313     I32 s1, t1;
8314
8315     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8316
8317     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8318         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8319         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8320     )
8321     {
8322         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8323         if (!keepcopy) {
8324             /* on something like
8325              *    $r = qr/.../;
8326              *    /$qr/p;
8327              * the KEEPCOPY is set on the PMOP rather than the regex */
8328             if (PL_curpm && r == PM_GETRE(PL_curpm))
8329                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8330         }
8331         if (!keepcopy)
8332             goto warn_undef;
8333     }
8334
8335     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8336     switch (paren) {
8337       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8338       case RX_BUFF_IDX_PREMATCH:       /* $` */
8339         if (rx->offs[0].start != -1) {
8340                         i = rx->offs[0].start;
8341                         if (i > 0) {
8342                                 s1 = 0;
8343                                 t1 = i;
8344                                 goto getlen;
8345                         }
8346             }
8347         return 0;
8348
8349       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8350       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8351             if (rx->offs[0].end != -1) {
8352                         i = rx->sublen - rx->offs[0].end;
8353                         if (i > 0) {
8354                                 s1 = rx->offs[0].end;
8355                                 t1 = rx->sublen;
8356                                 goto getlen;
8357                         }
8358             }
8359         return 0;
8360
8361       default: /* $& / ${^MATCH}, $1, $2, ... */
8362             if (paren <= (I32)rx->nparens &&
8363             (s1 = rx->offs[paren].start) != -1 &&
8364             (t1 = rx->offs[paren].end) != -1)
8365             {
8366             i = t1 - s1;
8367             goto getlen;
8368         } else {
8369           warn_undef:
8370             if (ckWARN(WARN_UNINITIALIZED))
8371                 report_uninit((const SV *)sv);
8372             return 0;
8373         }
8374     }
8375   getlen:
8376     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8377         const char * const s = rx->subbeg - rx->suboffset + s1;
8378         const U8 *ep;
8379         STRLEN el;
8380
8381         i = t1 - s1;
8382         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8383                         i = el;
8384     }
8385     return i;
8386 }
8387
8388 SV*
8389 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8390 {
8391     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8392         PERL_UNUSED_ARG(rx);
8393         if (0)
8394             return NULL;
8395         else
8396             return newSVpvs("Regexp");
8397 }
8398
8399 /* Scans the name of a named buffer from the pattern.
8400  * If flags is REG_RSN_RETURN_NULL returns null.
8401  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8402  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8403  * to the parsed name as looked up in the RExC_paren_names hash.
8404  * If there is an error throws a vFAIL().. type exception.
8405  */
8406
8407 #define REG_RSN_RETURN_NULL    0
8408 #define REG_RSN_RETURN_NAME    1
8409 #define REG_RSN_RETURN_DATA    2
8410
8411 STATIC SV*
8412 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8413 {
8414     char *name_start = RExC_parse;
8415
8416     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8417
8418     assert (RExC_parse <= RExC_end);
8419     if (RExC_parse == RExC_end) NOOP;
8420     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8421          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8422           * using do...while */
8423         if (UTF)
8424             do {
8425                 RExC_parse += UTF8SKIP(RExC_parse);
8426             } while (   RExC_parse < RExC_end
8427                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8428         else
8429             do {
8430                 RExC_parse++;
8431             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8432     } else {
8433         RExC_parse++; /* so the <- from the vFAIL is after the offending
8434                          character */
8435         vFAIL("Group name must start with a non-digit word character");
8436     }
8437     if ( flags ) {
8438         SV* sv_name
8439             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8440                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8441         if ( flags == REG_RSN_RETURN_NAME)
8442             return sv_name;
8443         else if (flags==REG_RSN_RETURN_DATA) {
8444             HE *he_str = NULL;
8445             SV *sv_dat = NULL;
8446             if ( ! sv_name )      /* should not happen*/
8447                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8448             if (RExC_paren_names)
8449                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8450             if ( he_str )
8451                 sv_dat = HeVAL(he_str);
8452             if ( ! sv_dat )
8453                 vFAIL("Reference to nonexistent named group");
8454             return sv_dat;
8455         }
8456         else {
8457             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8458                        (unsigned long) flags);
8459         }
8460         NOT_REACHED; /* NOTREACHED */
8461     }
8462     return NULL;
8463 }
8464
8465 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8466     int num;                                                    \
8467     if (RExC_lastparse!=RExC_parse) {                           \
8468         Perl_re_printf( aTHX_  "%s",                                        \
8469             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8470                 RExC_end - RExC_parse, 16,                      \
8471                 "", "",                                         \
8472                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8473                 PERL_PV_PRETTY_ELLIPSES   |                     \
8474                 PERL_PV_PRETTY_LTGT       |                     \
8475                 PERL_PV_ESCAPE_RE         |                     \
8476                 PERL_PV_PRETTY_EXACTSIZE                        \
8477             )                                                   \
8478         );                                                      \
8479     } else                                                      \
8480         Perl_re_printf( aTHX_ "%16s","");                                   \
8481                                                                 \
8482     if (SIZE_ONLY)                                              \
8483        num = RExC_size + 1;                                     \
8484     else                                                        \
8485        num=REG_NODE_NUM(RExC_emit);                             \
8486     if (RExC_lastnum!=num)                                      \
8487        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8488     else                                                        \
8489        Perl_re_printf( aTHX_ "|%4s","");                                    \
8490     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8491         (int)((depth*2)), "",                                   \
8492         (funcname)                                              \
8493     );                                                          \
8494     RExC_lastnum=num;                                           \
8495     RExC_lastparse=RExC_parse;                                  \
8496 })
8497
8498
8499
8500 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8501     DEBUG_PARSE_MSG((funcname));                            \
8502     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8503 })
8504 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8505     DEBUG_PARSE_MSG((funcname));                            \
8506     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8507 })
8508
8509 /* This section of code defines the inversion list object and its methods.  The
8510  * interfaces are highly subject to change, so as much as possible is static to
8511  * this file.  An inversion list is here implemented as a malloc'd C UV array
8512  * as an SVt_INVLIST scalar.
8513  *
8514  * An inversion list for Unicode is an array of code points, sorted by ordinal
8515  * number.  Each element gives the code point that begins a range that extends
8516  * up-to but not including the code point given by the next element.  The final
8517  * element gives the first code point of a range that extends to the platform's
8518  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8519  * ...) give ranges whose code points are all in the inversion list.  We say
8520  * that those ranges are in the set.  The odd-numbered elements give ranges
8521  * whose code points are not in the inversion list, and hence not in the set.
8522  * Thus, element [0] is the first code point in the list.  Element [1]
8523  * is the first code point beyond that not in the list; and element [2] is the
8524  * first code point beyond that that is in the list.  In other words, the first
8525  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8526  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8527  * all code points in that range are not in the inversion list.  The third
8528  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8529  * list, and so forth.  Thus every element whose index is divisible by two
8530  * gives the beginning of a range that is in the list, and every element whose
8531  * index is not divisible by two gives the beginning of a range not in the
8532  * list.  If the final element's index is divisible by two, the inversion list
8533  * extends to the platform's infinity; otherwise the highest code point in the
8534  * inversion list is the contents of that element minus 1.
8535  *
8536  * A range that contains just a single code point N will look like
8537  *  invlist[i]   == N
8538  *  invlist[i+1] == N+1
8539  *
8540  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8541  * impossible to represent, so element [i+1] is omitted.  The single element
8542  * inversion list
8543  *  invlist[0] == UV_MAX
8544  * contains just UV_MAX, but is interpreted as matching to infinity.
8545  *
8546  * Taking the complement (inverting) an inversion list is quite simple, if the
8547  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8548  * This implementation reserves an element at the beginning of each inversion
8549  * list to always contain 0; there is an additional flag in the header which
8550  * indicates if the list begins at the 0, or is offset to begin at the next
8551  * element.  This means that the inversion list can be inverted without any
8552  * copying; just flip the flag.
8553  *
8554  * More about inversion lists can be found in "Unicode Demystified"
8555  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8556  *
8557  * The inversion list data structure is currently implemented as an SV pointing
8558  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8559  * array of UV whose memory management is automatically handled by the existing
8560  * facilities for SV's.
8561  *
8562  * Some of the methods should always be private to the implementation, and some
8563  * should eventually be made public */
8564
8565 /* The header definitions are in F<invlist_inline.h> */
8566
8567 #ifndef PERL_IN_XSUB_RE
8568
8569 PERL_STATIC_INLINE UV*
8570 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8571 {
8572     /* Returns a pointer to the first element in the inversion list's array.
8573      * This is called upon initialization of an inversion list.  Where the
8574      * array begins depends on whether the list has the code point U+0000 in it
8575      * or not.  The other parameter tells it whether the code that follows this
8576      * call is about to put a 0 in the inversion list or not.  The first
8577      * element is either the element reserved for 0, if TRUE, or the element
8578      * after it, if FALSE */
8579
8580     bool* offset = get_invlist_offset_addr(invlist);
8581     UV* zero_addr = (UV *) SvPVX(invlist);
8582
8583     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8584
8585     /* Must be empty */
8586     assert(! _invlist_len(invlist));
8587
8588     *zero_addr = 0;
8589
8590     /* 1^1 = 0; 1^0 = 1 */
8591     *offset = 1 ^ will_have_0;
8592     return zero_addr + *offset;
8593 }
8594
8595 #endif
8596
8597 PERL_STATIC_INLINE void
8598 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8599 {
8600     /* Sets the current number of elements stored in the inversion list.
8601      * Updates SvCUR correspondingly */
8602     PERL_UNUSED_CONTEXT;
8603     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8604
8605     assert(SvTYPE(invlist) == SVt_INVLIST);
8606
8607     SvCUR_set(invlist,
8608               (len == 0)
8609                ? 0
8610                : TO_INTERNAL_SIZE(len + offset));
8611     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8612 }
8613
8614 #ifndef PERL_IN_XSUB_RE
8615
8616 STATIC void
8617 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8618 {
8619     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
8620      * steals the list from 'src', so 'src' is made to have a NULL list.  This
8621      * is similar to what SvSetMagicSV() would do, if it were implemented on
8622      * inversion lists, though this routine avoids a copy */
8623
8624     const UV src_len          = _invlist_len(src);
8625     const bool src_offset     = *get_invlist_offset_addr(src);
8626     const STRLEN src_byte_len = SvLEN(src);
8627     char * array              = SvPVX(src);
8628
8629     const int oldtainted = TAINT_get;
8630
8631     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8632
8633     assert(SvTYPE(src) == SVt_INVLIST);
8634     assert(SvTYPE(dest) == SVt_INVLIST);
8635     assert(! invlist_is_iterating(src));
8636     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8637
8638     /* Make sure it ends in the right place with a NUL, as our inversion list
8639      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8640      * asserts it */
8641     array[src_byte_len - 1] = '\0';
8642
8643     TAINT_NOT;      /* Otherwise it breaks */
8644     sv_usepvn_flags(dest,
8645                     (char *) array,
8646                     src_byte_len - 1,
8647
8648                     /* This flag is documented to cause a copy to be avoided */
8649                     SV_HAS_TRAILING_NUL);
8650     TAINT_set(oldtainted);
8651     SvPV_set(src, 0);
8652     SvLEN_set(src, 0);
8653     SvCUR_set(src, 0);
8654
8655     /* Finish up copying over the other fields in an inversion list */
8656     *get_invlist_offset_addr(dest) = src_offset;
8657     invlist_set_len(dest, src_len, src_offset);
8658     *get_invlist_previous_index_addr(dest) = 0;
8659     invlist_iterfinish(dest);
8660 }
8661
8662 PERL_STATIC_INLINE IV*
8663 S_get_invlist_previous_index_addr(SV* invlist)
8664 {
8665     /* Return the address of the IV that is reserved to hold the cached index
8666      * */
8667     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8668
8669     assert(SvTYPE(invlist) == SVt_INVLIST);
8670
8671     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8672 }
8673
8674 PERL_STATIC_INLINE IV
8675 S_invlist_previous_index(SV* const invlist)
8676 {
8677     /* Returns cached index of previous search */
8678
8679     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8680
8681     return *get_invlist_previous_index_addr(invlist);
8682 }
8683
8684 PERL_STATIC_INLINE void
8685 S_invlist_set_previous_index(SV* const invlist, const IV index)
8686 {
8687     /* Caches <index> for later retrieval */
8688
8689     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8690
8691     assert(index == 0 || index < (int) _invlist_len(invlist));
8692
8693     *get_invlist_previous_index_addr(invlist) = index;
8694 }
8695
8696 PERL_STATIC_INLINE void
8697 S_invlist_trim(SV* invlist)
8698 {
8699     /* Free the not currently-being-used space in an inversion list */
8700
8701     /* But don't free up the space needed for the 0 UV that is always at the
8702      * beginning of the list, nor the trailing NUL */
8703     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8704
8705     PERL_ARGS_ASSERT_INVLIST_TRIM;
8706
8707     assert(SvTYPE(invlist) == SVt_INVLIST);
8708
8709     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8710 }
8711
8712 PERL_STATIC_INLINE void
8713 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8714 {
8715     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8716
8717     assert(SvTYPE(invlist) == SVt_INVLIST);
8718
8719     invlist_set_len(invlist, 0, 0);
8720     invlist_trim(invlist);
8721 }
8722
8723 #endif /* ifndef PERL_IN_XSUB_RE */
8724
8725 PERL_STATIC_INLINE bool
8726 S_invlist_is_iterating(SV* const invlist)
8727 {
8728     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8729
8730     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8731 }
8732
8733 #ifndef PERL_IN_XSUB_RE
8734
8735 PERL_STATIC_INLINE UV
8736 S_invlist_max(SV* const invlist)
8737 {
8738     /* Returns the maximum number of elements storable in the inversion list's
8739      * array, without having to realloc() */
8740
8741     PERL_ARGS_ASSERT_INVLIST_MAX;
8742
8743     assert(SvTYPE(invlist) == SVt_INVLIST);
8744
8745     /* Assumes worst case, in which the 0 element is not counted in the
8746      * inversion list, so subtracts 1 for that */
8747     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8748            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8749            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8750 }
8751 SV*
8752 Perl__new_invlist(pTHX_ IV initial_size)
8753 {
8754
8755     /* Return a pointer to a newly constructed inversion list, with enough
8756      * space to store 'initial_size' elements.  If that number is negative, a
8757      * system default is used instead */
8758
8759     SV* new_list;
8760
8761     if (initial_size < 0) {
8762         initial_size = 10;
8763     }
8764
8765     /* Allocate the initial space */
8766     new_list = newSV_type(SVt_INVLIST);
8767
8768     /* First 1 is in case the zero element isn't in the list; second 1 is for
8769      * trailing NUL */
8770     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8771     invlist_set_len(new_list, 0, 0);
8772
8773     /* Force iterinit() to be used to get iteration to work */
8774     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8775
8776     *get_invlist_previous_index_addr(new_list) = 0;
8777
8778     return new_list;
8779 }
8780
8781 SV*
8782 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8783 {
8784     /* Return a pointer to a newly constructed inversion list, initialized to
8785      * point to <list>, which has to be in the exact correct inversion list
8786      * form, including internal fields.  Thus this is a dangerous routine that
8787      * should not be used in the wrong hands.  The passed in 'list' contains
8788      * several header fields at the beginning that are not part of the
8789      * inversion list body proper */
8790
8791     const STRLEN length = (STRLEN) list[0];
8792     const UV version_id =          list[1];
8793     const bool offset   =    cBOOL(list[2]);
8794 #define HEADER_LENGTH 3
8795     /* If any of the above changes in any way, you must change HEADER_LENGTH
8796      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8797      *      perl -E 'say int(rand 2**31-1)'
8798      */
8799 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8800                                         data structure type, so that one being
8801                                         passed in can be validated to be an
8802                                         inversion list of the correct vintage.
8803                                        */
8804
8805     SV* invlist = newSV_type(SVt_INVLIST);
8806
8807     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8808
8809     if (version_id != INVLIST_VERSION_ID) {
8810         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8811     }
8812
8813     /* The generated array passed in includes header elements that aren't part
8814      * of the list proper, so start it just after them */
8815     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8816
8817     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8818                                shouldn't touch it */
8819
8820     *(get_invlist_offset_addr(invlist)) = offset;
8821
8822     /* The 'length' passed to us is the physical number of elements in the
8823      * inversion list.  But if there is an offset the logical number is one
8824      * less than that */
8825     invlist_set_len(invlist, length  - offset, offset);
8826
8827     invlist_set_previous_index(invlist, 0);
8828
8829     /* Initialize the iteration pointer. */
8830     invlist_iterfinish(invlist);
8831
8832     SvREADONLY_on(invlist);
8833
8834     return invlist;
8835 }
8836
8837 STATIC void
8838 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8839 {
8840     /* Grow the maximum size of an inversion list */
8841
8842     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8843
8844     assert(SvTYPE(invlist) == SVt_INVLIST);
8845
8846     /* Add one to account for the zero element at the beginning which may not
8847      * be counted by the calling parameters */
8848     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8849 }
8850
8851 STATIC void
8852 S__append_range_to_invlist(pTHX_ SV* const invlist,
8853                                  const UV start, const UV end)
8854 {
8855    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8856     * the end of the inversion list.  The range must be above any existing
8857     * ones. */
8858
8859     UV* array;
8860     UV max = invlist_max(invlist);
8861     UV len = _invlist_len(invlist);
8862     bool offset;
8863
8864     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8865
8866     if (len == 0) { /* Empty lists must be initialized */
8867         offset = start != 0;
8868         array = _invlist_array_init(invlist, ! offset);
8869     }
8870     else {
8871         /* Here, the existing list is non-empty. The current max entry in the
8872          * list is generally the first value not in the set, except when the
8873          * set extends to the end of permissible values, in which case it is
8874          * the first entry in that final set, and so this call is an attempt to
8875          * append out-of-order */
8876
8877         UV final_element = len - 1;
8878         array = invlist_array(invlist);
8879         if (   array[final_element] > start
8880             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8881         {
8882             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",
8883                      array[final_element], start,
8884                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8885         }
8886
8887         /* Here, it is a legal append.  If the new range begins 1 above the end
8888          * of the range below it, it is extending the range below it, so the
8889          * new first value not in the set is one greater than the newly
8890          * extended range.  */
8891         offset = *get_invlist_offset_addr(invlist);
8892         if (array[final_element] == start) {
8893             if (end != UV_MAX) {
8894                 array[final_element] = end + 1;
8895             }
8896             else {
8897                 /* But if the end is the maximum representable on the machine,
8898                  * assume that infinity was actually what was meant.  Just let
8899                  * the range that this would extend to have no end */
8900                 invlist_set_len(invlist, len - 1, offset);
8901             }
8902             return;
8903         }
8904     }
8905
8906     /* Here the new range doesn't extend any existing set.  Add it */
8907
8908     len += 2;   /* Includes an element each for the start and end of range */
8909
8910     /* If wll overflow the existing space, extend, which may cause the array to
8911      * be moved */
8912     if (max < len) {
8913         invlist_extend(invlist, len);
8914
8915         /* Have to set len here to avoid assert failure in invlist_array() */
8916         invlist_set_len(invlist, len, offset);
8917
8918         array = invlist_array(invlist);
8919     }
8920     else {
8921         invlist_set_len(invlist, len, offset);
8922     }
8923
8924     /* The next item on the list starts the range, the one after that is
8925      * one past the new range.  */
8926     array[len - 2] = start;
8927     if (end != UV_MAX) {
8928         array[len - 1] = end + 1;
8929     }
8930     else {
8931         /* But if the end is the maximum representable on the machine, just let
8932          * the range have no end */
8933         invlist_set_len(invlist, len - 1, offset);
8934     }
8935 }
8936
8937 SSize_t
8938 Perl__invlist_search(SV* const invlist, const UV cp)
8939 {
8940     /* Searches the inversion list for the entry that contains the input code
8941      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8942      * return value is the index into the list's array of the range that
8943      * contains <cp>, that is, 'i' such that
8944      *  array[i] <= cp < array[i+1]
8945      */
8946
8947     IV low = 0;
8948     IV mid;
8949     IV high = _invlist_len(invlist);
8950     const IV highest_element = high - 1;
8951     const UV* array;
8952
8953     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8954
8955     /* If list is empty, return failure. */
8956     if (high == 0) {
8957         return -1;
8958     }
8959
8960     /* (We can't get the array unless we know the list is non-empty) */
8961     array = invlist_array(invlist);
8962
8963     mid = invlist_previous_index(invlist);
8964     assert(mid >=0);
8965     if (mid > highest_element) {
8966         mid = highest_element;
8967     }
8968
8969     /* <mid> contains the cache of the result of the previous call to this
8970      * function (0 the first time).  See if this call is for the same result,
8971      * or if it is for mid-1.  This is under the theory that calls to this
8972      * function will often be for related code points that are near each other.
8973      * And benchmarks show that caching gives better results.  We also test
8974      * here if the code point is within the bounds of the list.  These tests
8975      * replace others that would have had to be made anyway to make sure that
8976      * the array bounds were not exceeded, and these give us extra information
8977      * at the same time */
8978     if (cp >= array[mid]) {
8979         if (cp >= array[highest_element]) {
8980             return highest_element;
8981         }
8982
8983         /* Here, array[mid] <= cp < array[highest_element].  This means that
8984          * the final element is not the answer, so can exclude it; it also
8985          * means that <mid> is not the final element, so can refer to 'mid + 1'
8986          * safely */
8987         if (cp < array[mid + 1]) {
8988             return mid;
8989         }
8990         high--;
8991         low = mid + 1;
8992     }
8993     else { /* cp < aray[mid] */
8994         if (cp < array[0]) { /* Fail if outside the array */
8995             return -1;
8996         }
8997         high = mid;
8998         if (cp >= array[mid - 1]) {
8999             goto found_entry;
9000         }
9001     }
9002
9003     /* Binary search.  What we are looking for is <i> such that
9004      *  array[i] <= cp < array[i+1]
9005      * The loop below converges on the i+1.  Note that there may not be an
9006      * (i+1)th element in the array, and things work nonetheless */
9007     while (low < high) {
9008         mid = (low + high) / 2;
9009         assert(mid <= highest_element);
9010         if (array[mid] <= cp) { /* cp >= array[mid] */
9011             low = mid + 1;
9012
9013             /* We could do this extra test to exit the loop early.
9014             if (cp < array[low]) {
9015                 return mid;
9016             }
9017             */
9018         }
9019         else { /* cp < array[mid] */
9020             high = mid;
9021         }
9022     }
9023
9024   found_entry:
9025     high--;
9026     invlist_set_previous_index(invlist, high);
9027     return high;
9028 }
9029
9030 void
9031 Perl__invlist_populate_swatch(SV* const invlist,
9032                               const UV start, const UV end, U8* swatch)
9033 {
9034     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
9035      * but is used when the swash has an inversion list.  This makes this much
9036      * faster, as it uses a binary search instead of a linear one.  This is
9037      * intimately tied to that function, and perhaps should be in utf8.c,
9038      * except it is intimately tied to inversion lists as well.  It assumes
9039      * that <swatch> is all 0's on input */
9040
9041     UV current = start;
9042     const IV len = _invlist_len(invlist);
9043     IV i;
9044     const UV * array;
9045
9046     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
9047
9048     if (len == 0) { /* Empty inversion list */
9049         return;
9050     }
9051
9052     array = invlist_array(invlist);
9053
9054     /* Find which element it is */
9055     i = _invlist_search(invlist, start);
9056
9057     /* We populate from <start> to <end> */
9058     while (current < end) {
9059         UV upper;
9060
9061         /* The inversion list gives the results for every possible code point
9062          * after the first one in the list.  Only those ranges whose index is
9063          * even are ones that the inversion list matches.  For the odd ones,
9064          * and if the initial code point is not in the list, we have to skip
9065          * forward to the next element */
9066         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
9067             i++;
9068             if (i >= len) { /* Finished if beyond the end of the array */
9069                 return;
9070             }
9071             current = array[i];
9072             if (current >= end) {   /* Finished if beyond the end of what we
9073                                        are populating */
9074                 if (LIKELY(end < UV_MAX)) {
9075                     return;
9076                 }
9077
9078                 /* We get here when the upper bound is the maximum
9079                  * representable on the machine, and we are looking for just
9080                  * that code point.  Have to special case it */
9081                 i = len;
9082                 goto join_end_of_list;
9083             }
9084         }
9085         assert(current >= start);
9086
9087         /* The current range ends one below the next one, except don't go past
9088          * <end> */
9089         i++;
9090         upper = (i < len && array[i] < end) ? array[i] : end;
9091
9092         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
9093          * for each code point in it */
9094         for (; current < upper; current++) {
9095             const STRLEN offset = (STRLEN)(current - start);
9096             swatch[offset >> 3] |= 1 << (offset & 7);
9097         }
9098
9099       join_end_of_list:
9100
9101         /* Quit if at the end of the list */
9102         if (i >= len) {
9103
9104             /* But first, have to deal with the highest possible code point on
9105              * the platform.  The previous code assumes that <end> is one
9106              * beyond where we want to populate, but that is impossible at the
9107              * platform's infinity, so have to handle it specially */
9108             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
9109             {
9110                 const STRLEN offset = (STRLEN)(end - start);
9111                 swatch[offset >> 3] |= 1 << (offset & 7);
9112             }
9113             return;
9114         }
9115
9116         /* Advance to the next range, which will be for code points not in the
9117          * inversion list */
9118         current = array[i];
9119     }
9120
9121     return;
9122 }
9123
9124 void
9125 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9126                                          const bool complement_b, SV** output)
9127 {
9128     /* Take the union of two inversion lists and point '*output' to it.  On
9129      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9130      * even 'a' or 'b').  If to an inversion list, the contents of the original
9131      * list will be replaced by the union.  The first list, 'a', may be
9132      * NULL, in which case a copy of the second list is placed in '*output'.
9133      * If 'complement_b' is TRUE, the union is taken of the complement
9134      * (inversion) of 'b' instead of b itself.
9135      *
9136      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9137      * Richard Gillam, published by Addison-Wesley, and explained at some
9138      * length there.  The preface says to incorporate its examples into your
9139      * code at your own risk.
9140      *
9141      * The algorithm is like a merge sort. */
9142
9143     const UV* array_a;    /* a's array */
9144     const UV* array_b;
9145     UV len_a;       /* length of a's array */
9146     UV len_b;
9147
9148     SV* u;                      /* the resulting union */
9149     UV* array_u;
9150     UV len_u = 0;
9151
9152     UV i_a = 0;             /* current index into a's array */
9153     UV i_b = 0;
9154     UV i_u = 0;
9155
9156     /* running count, as explained in the algorithm source book; items are
9157      * stopped accumulating and are output when the count changes to/from 0.
9158      * The count is incremented when we start a range that's in an input's set,
9159      * and decremented when we start a range that's not in a set.  So this
9160      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9161      * and hence nothing goes into the union; 1, just one of the inputs is in
9162      * its set (and its current range gets added to the union); and 2 when both
9163      * inputs are in their sets.  */
9164     UV count = 0;
9165
9166     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9167     assert(a != b);
9168     assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
9169
9170     len_b = _invlist_len(b);
9171     if (len_b == 0) {
9172
9173         /* Here, 'b' is empty, hence it's complement is all possible code
9174          * points.  So if the union includes the complement of 'b', it includes
9175          * everything, and we need not even look at 'a'.  It's easiest to
9176          * create a new inversion list that matches everything.  */
9177         if (complement_b) {
9178             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9179
9180             if (*output == NULL) { /* If the output didn't exist, just point it
9181                                       at the new list */
9182                 *output = everything;
9183             }
9184             else { /* Otherwise, replace its contents with the new list */
9185                 invlist_replace_list_destroys_src(*output, everything);
9186                 SvREFCNT_dec_NN(everything);
9187             }
9188
9189             return;
9190         }
9191
9192         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9193          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9194          * output will be empty */
9195
9196         if (a == NULL || _invlist_len(a) == 0) {
9197             if (*output == NULL) {
9198                 *output = _new_invlist(0);
9199             }
9200             else {
9201                 invlist_clear(*output);
9202             }
9203             return;
9204         }
9205
9206         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9207          * union.  We can just return a copy of 'a' if '*output' doesn't point
9208          * to an existing list */
9209         if (*output == NULL) {
9210             *output = invlist_clone(a);
9211             return;
9212         }
9213
9214         /* If the output is to overwrite 'a', we have a no-op, as it's
9215          * already in 'a' */
9216         if (*output == a) {
9217             return;
9218         }
9219
9220         /* Here, '*output' is to be overwritten by 'a' */
9221         u = invlist_clone(a);
9222         invlist_replace_list_destroys_src(*output, u);
9223         SvREFCNT_dec_NN(u);
9224
9225         return;
9226     }
9227
9228     /* Here 'b' is not empty.  See about 'a' */
9229
9230     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9231
9232         /* Here, 'a' is empty (and b is not).  That means the union will come
9233          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9234          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9235          * the clone */
9236
9237         SV ** dest = (*output == NULL) ? output : &u;
9238         *dest = invlist_clone(b);
9239         if (complement_b) {
9240             _invlist_invert(*dest);
9241         }
9242
9243         if (dest == &u) {
9244             invlist_replace_list_destroys_src(*output, u);
9245             SvREFCNT_dec_NN(u);
9246         }
9247
9248         return;
9249     }
9250
9251     /* Here both lists exist and are non-empty */
9252     array_a = invlist_array(a);
9253     array_b = invlist_array(b);
9254
9255     /* If are to take the union of 'a' with the complement of b, set it
9256      * up so are looking at b's complement. */
9257     if (complement_b) {
9258
9259         /* To complement, we invert: if the first element is 0, remove it.  To
9260          * do this, we just pretend the array starts one later */
9261         if (array_b[0] == 0) {
9262             array_b++;
9263             len_b--;
9264         }
9265         else {
9266
9267             /* But if the first element is not zero, we pretend the list starts
9268              * at the 0 that is always stored immediately before the array. */
9269             array_b--;
9270             len_b++;
9271         }
9272     }
9273
9274     /* Size the union for the worst case: that the sets are completely
9275      * disjoint */
9276     u = _new_invlist(len_a + len_b);
9277
9278     /* Will contain U+0000 if either component does */
9279     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9280                                       || (len_b > 0 && array_b[0] == 0));
9281
9282     /* Go through each input list item by item, stopping when have exhausted
9283      * one of them */
9284     while (i_a < len_a && i_b < len_b) {
9285         UV cp;      /* The element to potentially add to the union's array */
9286         bool cp_in_set;   /* is it in the the input list's set or not */
9287
9288         /* We need to take one or the other of the two inputs for the union.
9289          * Since we are merging two sorted lists, we take the smaller of the
9290          * next items.  In case of a tie, we take first the one that is in its
9291          * set.  If we first took the one not in its set, it would decrement
9292          * the count, possibly to 0 which would cause it to be output as ending
9293          * the range, and the next time through we would take the same number,
9294          * and output it again as beginning the next range.  By doing it the
9295          * opposite way, there is no possibility that the count will be
9296          * momentarily decremented to 0, and thus the two adjoining ranges will
9297          * be seamlessly merged.  (In a tie and both are in the set or both not
9298          * in the set, it doesn't matter which we take first.) */
9299         if (       array_a[i_a] < array_b[i_b]
9300             || (   array_a[i_a] == array_b[i_b]
9301                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9302         {
9303             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9304             cp = array_a[i_a++];
9305         }
9306         else {
9307             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9308             cp = array_b[i_b++];
9309         }
9310
9311         /* Here, have chosen which of the two inputs to look at.  Only output
9312          * if the running count changes to/from 0, which marks the
9313          * beginning/end of a range that's in the set */
9314         if (cp_in_set) {
9315             if (count == 0) {
9316                 array_u[i_u++] = cp;
9317             }
9318             count++;
9319         }
9320         else {
9321             count--;
9322             if (count == 0) {
9323                 array_u[i_u++] = cp;
9324             }
9325         }
9326     }
9327
9328
9329     /* The loop above increments the index into exactly one of the input lists
9330      * each iteration, and ends when either index gets to its list end.  That
9331      * means the other index is lower than its end, and so something is
9332      * remaining in that one.  We decrement 'count', as explained below, if
9333      * that list is in its set.  (i_a and i_b each currently index the element
9334      * beyond the one we care about.) */
9335     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9336         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9337     {
9338         count--;
9339     }
9340
9341     /* Above we decremented 'count' if the list that had unexamined elements in
9342      * it was in its set.  This has made it so that 'count' being non-zero
9343      * means there isn't anything left to output; and 'count' equal to 0 means
9344      * that what is left to output is precisely that which is left in the
9345      * non-exhausted input list.
9346      *
9347      * To see why, note first that the exhausted input obviously has nothing
9348      * left to add to the union.  If it was in its set at its end, that means
9349      * the set extends from here to the platform's infinity, and hence so does
9350      * the union and the non-exhausted set is irrelevant.  The exhausted set
9351      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9352      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9353      * 'count' remains at 1.  This is consistent with the decremented 'count'
9354      * != 0 meaning there's nothing left to add to the union.
9355      *
9356      * But if the exhausted input wasn't in its set, it contributed 0 to
9357      * 'count', and the rest of the union will be whatever the other input is.
9358      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9359      * otherwise it gets decremented to 0.  This is consistent with 'count'
9360      * == 0 meaning the remainder of the union is whatever is left in the
9361      * non-exhausted list. */
9362     if (count != 0) {
9363         len_u = i_u;
9364     }
9365     else {
9366         IV copy_count = len_a - i_a;
9367         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9368             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9369         }
9370         else { /* The non-exhausted input is b */
9371             copy_count = len_b - i_b;
9372             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9373         }
9374         len_u = i_u + copy_count;
9375     }
9376
9377     /* Set the result to the final length, which can change the pointer to
9378      * array_u, so re-find it.  (Note that it is unlikely that this will
9379      * change, as we are shrinking the space, not enlarging it) */
9380     if (len_u != _invlist_len(u)) {
9381         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9382         invlist_trim(u);
9383         array_u = invlist_array(u);
9384     }
9385
9386     if (*output == NULL) {  /* Simply return the new inversion list */
9387         *output = u;
9388     }
9389     else {
9390         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9391          * could instead free '*output', and then set it to 'u', but experience
9392          * has shown [perl #127392] that if the input is a mortal, we can get a
9393          * huge build-up of these during regex compilation before they get
9394          * freed. */
9395         invlist_replace_list_destroys_src(*output, u);
9396         SvREFCNT_dec_NN(u);
9397     }
9398
9399     return;
9400 }
9401
9402 void
9403 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9404                                                const bool complement_b, SV** i)
9405 {
9406     /* Take the intersection of two inversion lists and point '*i' to it.  On
9407      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9408      * even 'a' or 'b').  If to an inversion list, the contents of the original
9409      * list will be replaced by the intersection.  The first list, 'a', may be
9410      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9411      * TRUE, the result will be the intersection of 'a' and the complement (or
9412      * inversion) of 'b' instead of 'b' directly.
9413      *
9414      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9415      * Richard Gillam, published by Addison-Wesley, and explained at some
9416      * length there.  The preface says to incorporate its examples into your
9417      * code at your own risk.  In fact, it had bugs
9418      *
9419      * The algorithm is like a merge sort, and is essentially the same as the
9420      * union above
9421      */
9422
9423     const UV* array_a;          /* a's array */
9424     const UV* array_b;
9425     UV len_a;   /* length of a's array */
9426     UV len_b;
9427
9428     SV* r;                   /* the resulting intersection */
9429     UV* array_r;
9430     UV len_r = 0;
9431
9432     UV i_a = 0;             /* current index into a's array */
9433     UV i_b = 0;
9434     UV i_r = 0;
9435
9436     /* running count of how many of the two inputs are postitioned at ranges
9437      * that are in their sets.  As explained in the algorithm source book,
9438      * items are stopped accumulating and are output when the count changes
9439      * to/from 2.  The count is incremented when we start a range that's in an
9440      * input's set, and decremented when we start a range that's not in a set.
9441      * Only when it is 2 are we in the intersection. */
9442     UV count = 0;
9443
9444     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9445     assert(a != b);
9446     assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
9447
9448     /* Special case if either one is empty */
9449     len_a = (a == NULL) ? 0 : _invlist_len(a);
9450     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9451         if (len_a != 0 && complement_b) {
9452
9453             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9454              * must be empty.  Here, also we are using 'b's complement, which
9455              * hence must be every possible code point.  Thus the intersection
9456              * is simply 'a'. */
9457
9458             if (*i == a) {  /* No-op */
9459                 return;
9460             }
9461
9462             if (*i == NULL) {
9463                 *i = invlist_clone(a);
9464                 return;
9465             }
9466
9467             r = invlist_clone(a);
9468             invlist_replace_list_destroys_src(*i, r);
9469             SvREFCNT_dec_NN(r);
9470             return;
9471         }
9472
9473         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9474          * intersection must be empty */
9475         if (*i == NULL) {
9476             *i = _new_invlist(0);
9477             return;
9478         }
9479
9480         invlist_clear(*i);
9481         return;
9482     }
9483
9484     /* Here both lists exist and are non-empty */
9485     array_a = invlist_array(a);
9486     array_b = invlist_array(b);
9487
9488     /* If are to take the intersection of 'a' with the complement of b, set it
9489      * up so are looking at b's complement. */
9490     if (complement_b) {
9491
9492         /* To complement, we invert: if the first element is 0, remove it.  To
9493          * do this, we just pretend the array starts one later */
9494         if (array_b[0] == 0) {
9495             array_b++;
9496             len_b--;
9497         }
9498         else {
9499
9500             /* But if the first element is not zero, we pretend the list starts
9501              * at the 0 that is always stored immediately before the array. */
9502             array_b--;
9503             len_b++;
9504         }
9505     }
9506
9507     /* Size the intersection for the worst case: that the intersection ends up
9508      * fragmenting everything to be completely disjoint */
9509     r= _new_invlist(len_a + len_b);
9510
9511     /* Will contain U+0000 iff both components do */
9512     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9513                                      && len_b > 0 && array_b[0] == 0);
9514
9515     /* Go through each list item by item, stopping when have exhausted one of
9516      * them */
9517     while (i_a < len_a && i_b < len_b) {
9518         UV cp;      /* The element to potentially add to the intersection's
9519                        array */
9520         bool cp_in_set; /* Is it in the input list's set or not */
9521
9522         /* We need to take one or the other of the two inputs for the
9523          * intersection.  Since we are merging two sorted lists, we take the
9524          * smaller of the next items.  In case of a tie, we take first the one
9525          * that is not in its set (a difference from the union algorithm).  If
9526          * we first took the one in its set, it would increment the count,
9527          * possibly to 2 which would cause it to be output as starting a range
9528          * in the intersection, and the next time through we would take that
9529          * same number, and output it again as ending the set.  By doing the
9530          * opposite of this, there is no possibility that the count will be
9531          * momentarily incremented to 2.  (In a tie and both are in the set or
9532          * both not in the set, it doesn't matter which we take first.) */
9533         if (       array_a[i_a] < array_b[i_b]
9534             || (   array_a[i_a] == array_b[i_b]
9535                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9536         {
9537             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9538             cp = array_a[i_a++];
9539         }
9540         else {
9541             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9542             cp= array_b[i_b++];
9543         }
9544
9545         /* Here, have chosen which of the two inputs to look at.  Only output
9546          * if the running count changes to/from 2, which marks the
9547          * beginning/end of a range that's in the intersection */
9548         if (cp_in_set) {
9549             count++;
9550             if (count == 2) {
9551                 array_r[i_r++] = cp;
9552             }
9553         }
9554         else {
9555             if (count == 2) {
9556                 array_r[i_r++] = cp;
9557             }
9558             count--;
9559         }
9560
9561     }
9562
9563     /* The loop above increments the index into exactly one of the input lists
9564      * each iteration, and ends when either index gets to its list end.  That
9565      * means the other index is lower than its end, and so something is
9566      * remaining in that one.  We increment 'count', as explained below, if the
9567      * exhausted list was in its set.  (i_a and i_b each currently index the
9568      * element beyond the one we care about.) */
9569     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9570         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9571     {
9572         count++;
9573     }
9574
9575     /* Above we incremented 'count' if the exhausted list was in its set.  This
9576      * has made it so that 'count' being below 2 means there is nothing left to
9577      * output; otheriwse what's left to add to the intersection is precisely
9578      * that which is left in the non-exhausted input list.
9579      *
9580      * To see why, note first that the exhausted input obviously has nothing
9581      * left to affect the intersection.  If it was in its set at its end, that
9582      * means the set extends from here to the platform's infinity, and hence
9583      * anything in the non-exhausted's list will be in the intersection, and
9584      * anything not in it won't be.  Hence, the rest of the intersection is
9585      * precisely what's in the non-exhausted list  The exhausted set also
9586      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9587      * it means 'count' is now at least 2.  This is consistent with the
9588      * incremented 'count' being >= 2 means to add the non-exhausted list to
9589      * the intersection.
9590      *
9591      * But if the exhausted input wasn't in its set, it contributed 0 to
9592      * 'count', and the intersection can't include anything further; the
9593      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9594      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9595      * further to add to the intersection. */
9596     if (count < 2) { /* Nothing left to put in the intersection. */
9597         len_r = i_r;
9598     }
9599     else { /* copy the non-exhausted list, unchanged. */
9600         IV copy_count = len_a - i_a;
9601         if (copy_count > 0) {   /* a is the one with stuff left */
9602             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9603         }
9604         else {  /* b is the one with stuff left */
9605             copy_count = len_b - i_b;
9606             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9607         }
9608         len_r = i_r + copy_count;
9609     }
9610
9611     /* Set the result to the final length, which can change the pointer to
9612      * array_r, so re-find it.  (Note that it is unlikely that this will
9613      * change, as we are shrinking the space, not enlarging it) */
9614     if (len_r != _invlist_len(r)) {
9615         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9616         invlist_trim(r);
9617         array_r = invlist_array(r);
9618     }
9619
9620     if (*i == NULL) { /* Simply return the calculated intersection */
9621         *i = r;
9622     }
9623     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9624               instead free '*i', and then set it to 'r', but experience has
9625               shown [perl #127392] that if the input is a mortal, we can get a
9626               huge build-up of these during regex compilation before they get
9627               freed. */
9628         if (len_r) {
9629             invlist_replace_list_destroys_src(*i, r);
9630         }
9631         else {
9632             invlist_clear(*i);
9633         }
9634         SvREFCNT_dec_NN(r);
9635     }
9636
9637     return;
9638 }
9639
9640 SV*
9641 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9642 {
9643     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9644      * set.  A pointer to the inversion list is returned.  This may actually be
9645      * a new list, in which case the passed in one has been destroyed.  The
9646      * passed-in inversion list can be NULL, in which case a new one is created
9647      * with just the one range in it.  The new list is not necessarily
9648      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9649      * result of this function.  The gain would not be large, and in many
9650      * cases, this is called multiple times on a single inversion list, so
9651      * anything freed may almost immediately be needed again.
9652      *
9653      * This used to mostly call the 'union' routine, but that is much more
9654      * heavyweight than really needed for a single range addition */
9655
9656     UV* array;              /* The array implementing the inversion list */
9657     UV len;                 /* How many elements in 'array' */
9658     SSize_t i_s;            /* index into the invlist array where 'start'
9659                                should go */
9660     SSize_t i_e = 0;        /* And the index where 'end' should go */
9661     UV cur_highest;         /* The highest code point in the inversion list
9662                                upon entry to this function */
9663
9664     /* This range becomes the whole inversion list if none already existed */
9665     if (invlist == NULL) {
9666         invlist = _new_invlist(2);
9667         _append_range_to_invlist(invlist, start, end);
9668         return invlist;
9669     }
9670
9671     /* Likewise, if the inversion list is currently empty */
9672     len = _invlist_len(invlist);
9673     if (len == 0) {
9674         _append_range_to_invlist(invlist, start, end);
9675         return invlist;
9676     }
9677
9678     /* Starting here, we have to know the internals of the list */
9679     array = invlist_array(invlist);
9680
9681     /* If the new range ends higher than the current highest ... */
9682     cur_highest = invlist_highest(invlist);
9683     if (end > cur_highest) {
9684
9685         /* If the whole range is higher, we can just append it */
9686         if (start > cur_highest) {
9687             _append_range_to_invlist(invlist, start, end);
9688             return invlist;
9689         }
9690
9691         /* Otherwise, add the portion that is higher ... */
9692         _append_range_to_invlist(invlist, cur_highest + 1, end);
9693
9694         /* ... and continue on below to handle the rest.  As a result of the
9695          * above append, we know that the index of the end of the range is the
9696          * final even numbered one of the array.  Recall that the final element
9697          * always starts a range that extends to infinity.  If that range is in
9698          * the set (meaning the set goes from here to infinity), it will be an
9699          * even index, but if it isn't in the set, it's odd, and the final
9700          * range in the set is one less, which is even. */
9701         if (end == UV_MAX) {
9702             i_e = len;
9703         }
9704         else {
9705             i_e = len - 2;
9706         }
9707     }
9708
9709     /* We have dealt with appending, now see about prepending.  If the new
9710      * range starts lower than the current lowest ... */
9711     if (start < array[0]) {
9712
9713         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
9714          * Let the union code handle it, rather than having to know the
9715          * trickiness in two code places.  */
9716         if (UNLIKELY(start == 0)) {
9717             SV* range_invlist;
9718
9719             range_invlist = _new_invlist(2);
9720             _append_range_to_invlist(range_invlist, start, end);
9721
9722             _invlist_union(invlist, range_invlist, &invlist);
9723
9724             SvREFCNT_dec_NN(range_invlist);
9725
9726             return invlist;
9727         }
9728
9729         /* If the whole new range comes before the first entry, and doesn't
9730          * extend it, we have to insert it as an additional range */
9731         if (end < array[0] - 1) {
9732             i_s = i_e = -1;
9733             goto splice_in_new_range;
9734         }
9735
9736         /* Here the new range adjoins the existing first range, extending it
9737          * downwards. */
9738         array[0] = start;
9739
9740         /* And continue on below to handle the rest.  We know that the index of
9741          * the beginning of the range is the first one of the array */
9742         i_s = 0;
9743     }
9744     else { /* Not prepending any part of the new range to the existing list.
9745             * Find where in the list it should go.  This finds i_s, such that:
9746             *     invlist[i_s] <= start < array[i_s+1]
9747             */
9748         i_s = _invlist_search(invlist, start);
9749     }
9750
9751     /* At this point, any extending before the beginning of the inversion list
9752      * and/or after the end has been done.  This has made it so that, in the
9753      * code below, each endpoint of the new range is either in a range that is
9754      * in the set, or is in a gap between two ranges that are.  This means we
9755      * don't have to worry about exceeding the array bounds.
9756      *
9757      * Find where in the list the new range ends (but we can skip this if we
9758      * have already determined what it is, or if it will be the same as i_s,
9759      * which we already have computed) */
9760     if (i_e == 0) {
9761         i_e = (start == end)
9762               ? i_s
9763               : _invlist_search(invlist, end);
9764     }
9765
9766     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
9767      * is a range that goes to infinity there is no element at invlist[i_e+1],
9768      * so only the first relation holds. */
9769
9770     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9771
9772         /* Here, the ranges on either side of the beginning of the new range
9773          * are in the set, and this range starts in the gap between them.
9774          *
9775          * The new range extends the range above it downwards if the new range
9776          * ends at or above that range's start */
9777         const bool extends_the_range_above = (   end == UV_MAX
9778                                               || end + 1 >= array[i_s+1]);
9779
9780         /* The new range extends the range below it upwards if it begins just
9781          * after where that range ends */
9782         if (start == array[i_s]) {
9783
9784             /* If the new range fills the entire gap between the other ranges,
9785              * they will get merged together.  Other ranges may also get
9786              * merged, depending on how many of them the new range spans.  In
9787              * the general case, we do the merge later, just once, after we
9788              * figure out how many to merge.  But in the case where the new
9789              * range exactly spans just this one gap (possibly extending into
9790              * the one above), we do the merge here, and an early exit.  This
9791              * is done here to avoid having to special case later. */
9792             if (i_e - i_s <= 1) {
9793
9794                 /* If i_e - i_s == 1, it means that the new range terminates
9795                  * within the range above, and hence 'extends_the_range_above'
9796                  * must be true.  (If the range above it extends to infinity,
9797                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
9798                  * will be 0, so no harm done.) */
9799                 if (extends_the_range_above) {
9800                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
9801                     invlist_set_len(invlist,
9802                                     len - 2,
9803                                     *(get_invlist_offset_addr(invlist)));
9804                     return invlist;
9805                 }
9806
9807                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
9808                  * to the same range, and below we are about to decrement i_s
9809                  * */
9810                 i_e--;
9811             }
9812
9813             /* Here, the new range is adjacent to the one below.  (It may also
9814              * span beyond the range above, but that will get resolved later.)
9815              * Extend the range below to include this one. */
9816             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
9817             i_s--;
9818             start = array[i_s];
9819         }
9820         else if (extends_the_range_above) {
9821
9822             /* Here the new range only extends the range above it, but not the
9823              * one below.  It merges with the one above.  Again, we keep i_e
9824              * and i_s in sync if they point to the same range */
9825             if (i_e == i_s) {
9826                 i_e++;
9827             }
9828             i_s++;
9829             array[i_s] = start;
9830         }
9831     }
9832
9833     /* Here, we've dealt with the new range start extending any adjoining
9834      * existing ranges.
9835      *
9836      * If the new range extends to infinity, it is now the final one,
9837      * regardless of what was there before */
9838     if (UNLIKELY(end == UV_MAX)) {
9839         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
9840         return invlist;
9841     }
9842
9843     /* If i_e started as == i_s, it has also been dealt with,
9844      * and been updated to the new i_s, which will fail the following if */
9845     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
9846
9847         /* Here, the ranges on either side of the end of the new range are in
9848          * the set, and this range ends in the gap between them.
9849          *
9850          * If this range is adjacent to (hence extends) the range above it, it
9851          * becomes part of that range; likewise if it extends the range below,
9852          * it becomes part of that range */
9853         if (end + 1 == array[i_e+1]) {
9854             i_e++;
9855             array[i_e] = start;
9856         }
9857         else if (start <= array[i_e]) {
9858             array[i_e] = end + 1;
9859             i_e--;
9860         }
9861     }
9862
9863     if (i_s == i_e) {
9864
9865         /* If the range fits entirely in an existing range (as possibly already
9866          * extended above), it doesn't add anything new */
9867         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9868             return invlist;
9869         }
9870
9871         /* Here, no part of the range is in the list.  Must add it.  It will
9872          * occupy 2 more slots */
9873       splice_in_new_range:
9874
9875         invlist_extend(invlist, len + 2);
9876         array = invlist_array(invlist);
9877         /* Move the rest of the array down two slots. Don't include any
9878          * trailing NUL */
9879         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
9880
9881         /* Do the actual splice */
9882         array[i_e+1] = start;
9883         array[i_e+2] = end + 1;
9884         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
9885         return invlist;
9886     }
9887
9888     /* Here the new range crossed the boundaries of a pre-existing range.  The
9889      * code above has adjusted things so that both ends are in ranges that are
9890      * in the set.  This means everything in between must also be in the set.
9891      * Just squash things together */
9892     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
9893     invlist_set_len(invlist,
9894                     len - i_e + i_s,
9895                     *(get_invlist_offset_addr(invlist)));
9896
9897     return invlist;
9898 }
9899
9900 SV*
9901 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9902                                  UV** other_elements_ptr)
9903 {
9904     /* Create and return an inversion list whose contents are to be populated
9905      * by the caller.  The caller gives the number of elements (in 'size') and
9906      * the very first element ('element0').  This function will set
9907      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9908      * are to be placed.
9909      *
9910      * Obviously there is some trust involved that the caller will properly
9911      * fill in the other elements of the array.
9912      *
9913      * (The first element needs to be passed in, as the underlying code does
9914      * things differently depending on whether it is zero or non-zero) */
9915
9916     SV* invlist = _new_invlist(size);
9917     bool offset;
9918
9919     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9920
9921     invlist = add_cp_to_invlist(invlist, element0);
9922     offset = *get_invlist_offset_addr(invlist);
9923
9924     invlist_set_len(invlist, size, offset);
9925     *other_elements_ptr = invlist_array(invlist) + 1;
9926     return invlist;
9927 }
9928
9929 #endif
9930
9931 PERL_STATIC_INLINE SV*
9932 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9933     return _add_range_to_invlist(invlist, cp, cp);
9934 }
9935
9936 #ifndef PERL_IN_XSUB_RE
9937 void
9938 Perl__invlist_invert(pTHX_ SV* const invlist)
9939 {
9940     /* Complement the input inversion list.  This adds a 0 if the list didn't
9941      * have a zero; removes it otherwise.  As described above, the data
9942      * structure is set up so that this is very efficient */
9943
9944     PERL_ARGS_ASSERT__INVLIST_INVERT;
9945
9946     assert(! invlist_is_iterating(invlist));
9947
9948     /* The inverse of matching nothing is matching everything */
9949     if (_invlist_len(invlist) == 0) {
9950         _append_range_to_invlist(invlist, 0, UV_MAX);
9951         return;
9952     }
9953
9954     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9955 }
9956
9957 #endif
9958
9959 PERL_STATIC_INLINE SV*
9960 S_invlist_clone(pTHX_ SV* const invlist)
9961 {
9962
9963     /* Return a new inversion list that is a copy of the input one, which is
9964      * unchanged.  The new list will not be mortal even if the old one was. */
9965
9966     /* Need to allocate extra space to accommodate Perl's addition of a
9967      * trailing NUL to SvPV's, since it thinks they are always strings */
9968     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9969     STRLEN physical_length = SvCUR(invlist);
9970     bool offset = *(get_invlist_offset_addr(invlist));
9971
9972     PERL_ARGS_ASSERT_INVLIST_CLONE;
9973
9974     *(get_invlist_offset_addr(new_invlist)) = offset;
9975     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9976     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9977
9978     return new_invlist;
9979 }
9980
9981 PERL_STATIC_INLINE STRLEN*
9982 S_get_invlist_iter_addr(SV* invlist)
9983 {
9984     /* Return the address of the UV that contains the current iteration
9985      * position */
9986
9987     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9988
9989     assert(SvTYPE(invlist) == SVt_INVLIST);
9990
9991     return &(((XINVLIST*) SvANY(invlist))->iterator);
9992 }
9993
9994 PERL_STATIC_INLINE void
9995 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9996 {
9997     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9998
9999     *get_invlist_iter_addr(invlist) = 0;
10000 }
10001
10002 PERL_STATIC_INLINE void
10003 S_invlist_iterfinish(SV* invlist)
10004 {
10005     /* Terminate iterator for invlist.  This is to catch development errors.
10006      * Any iteration that is interrupted before completed should call this
10007      * function.  Functions that add code points anywhere else but to the end
10008      * of an inversion list assert that they are not in the middle of an
10009      * iteration.  If they were, the addition would make the iteration
10010      * problematical: if the iteration hadn't reached the place where things
10011      * were being added, it would be ok */
10012
10013     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
10014
10015     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
10016 }
10017
10018 STATIC bool
10019 S_invlist_iternext(SV* invlist, UV* start, UV* end)
10020 {
10021     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
10022      * This call sets in <*start> and <*end>, the next range in <invlist>.
10023      * Returns <TRUE> if successful and the next call will return the next
10024      * range; <FALSE> if was already at the end of the list.  If the latter,
10025      * <*start> and <*end> are unchanged, and the next call to this function
10026      * will start over at the beginning of the list */
10027
10028     STRLEN* pos = get_invlist_iter_addr(invlist);
10029     UV len = _invlist_len(invlist);
10030     UV *array;
10031
10032     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
10033
10034     if (*pos >= len) {
10035         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
10036         return FALSE;
10037     }
10038
10039     array = invlist_array(invlist);
10040
10041     *start = array[(*pos)++];
10042
10043     if (*pos >= len) {
10044         *end = UV_MAX;
10045     }
10046     else {
10047         *end = array[(*pos)++] - 1;
10048     }
10049
10050     return TRUE;
10051 }
10052
10053 PERL_STATIC_INLINE UV
10054 S_invlist_highest(SV* const invlist)
10055 {
10056     /* Returns the highest code point that matches an inversion list.  This API
10057      * has an ambiguity, as it returns 0 under either the highest is actually
10058      * 0, or if the list is empty.  If this distinction matters to you, check
10059      * for emptiness before calling this function */
10060
10061     UV len = _invlist_len(invlist);
10062     UV *array;
10063
10064     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
10065
10066     if (len == 0) {
10067         return 0;
10068     }
10069
10070     array = invlist_array(invlist);
10071
10072     /* The last element in the array in the inversion list always starts a
10073      * range that goes to infinity.  That range may be for code points that are
10074      * matched in the inversion list, or it may be for ones that aren't
10075      * matched.  In the latter case, the highest code point in the set is one
10076      * less than the beginning of this range; otherwise it is the final element
10077      * of this range: infinity */
10078     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
10079            ? UV_MAX
10080            : array[len - 1] - 1;
10081 }
10082
10083 STATIC SV *
10084 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
10085 {
10086     /* Get the contents of an inversion list into a string SV so that they can
10087      * be printed out.  If 'traditional_style' is TRUE, it uses the format
10088      * traditionally done for debug tracing; otherwise it uses a format
10089      * suitable for just copying to the output, with blanks between ranges and
10090      * a dash between range components */
10091
10092     UV start, end;
10093     SV* output;
10094     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
10095     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
10096
10097     if (traditional_style) {
10098         output = newSVpvs("\n");
10099     }
10100     else {
10101         output = newSVpvs("");
10102     }
10103
10104     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
10105
10106     assert(! invlist_is_iterating(invlist));
10107
10108     invlist_iterinit(invlist);
10109     while (invlist_iternext(invlist, &start, &end)) {
10110         if (end == UV_MAX) {
10111             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFINITY%c",
10112                                           start, intra_range_delimiter,
10113                                                  inter_range_delimiter);
10114         }
10115         else if (end != start) {
10116             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10117                                           start,
10118                                                    intra_range_delimiter,
10119                                                   end, inter_range_delimiter);
10120         }
10121         else {
10122             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10123                                           start, inter_range_delimiter);
10124         }
10125     }
10126
10127     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10128         SvCUR_set(output, SvCUR(output) - 1);
10129     }
10130
10131     return output;
10132 }
10133
10134 #ifndef PERL_IN_XSUB_RE
10135 void
10136 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10137                          const char * const indent, SV* const invlist)
10138 {
10139     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10140      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10141      * the string 'indent'.  The output looks like this:
10142          [0] 0x000A .. 0x000D
10143          [2] 0x0085
10144          [4] 0x2028 .. 0x2029
10145          [6] 0x3104 .. INFINITY
10146      * This means that the first range of code points matched by the list are
10147      * 0xA through 0xD; the second range contains only the single code point
10148      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10149      * are used to define each range (except if the final range extends to
10150      * infinity, only a single element is needed).  The array index of the
10151      * first element for the corresponding range is given in brackets. */
10152
10153     UV start, end;
10154     STRLEN count = 0;
10155
10156     PERL_ARGS_ASSERT__INVLIST_DUMP;
10157
10158     if (invlist_is_iterating(invlist)) {
10159         Perl_dump_indent(aTHX_ level, file,
10160              "%sCan't dump inversion list because is in middle of iterating\n",
10161              indent);
10162         return;
10163     }
10164
10165     invlist_iterinit(invlist);
10166     while (invlist_iternext(invlist, &start, &end)) {
10167         if (end == UV_MAX) {
10168             Perl_dump_indent(aTHX_ level, file,
10169                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFINITY\n",
10170                                    indent, (UV)count, start);
10171         }
10172         else if (end != start) {
10173             Perl_dump_indent(aTHX_ level, file,
10174                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10175                                 indent, (UV)count, start,         end);
10176         }
10177         else {
10178             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10179                                             indent, (UV)count, start);
10180         }
10181         count += 2;
10182     }
10183 }
10184
10185 void
10186 Perl__load_PL_utf8_foldclosures (pTHX)
10187 {
10188     assert(! PL_utf8_foldclosures);
10189
10190     /* If the folds haven't been read in, call a fold function
10191      * to force that */
10192     if (! PL_utf8_tofold) {
10193         U8 dummy[UTF8_MAXBYTES_CASE+1];
10194         const U8 hyphen[] = HYPHEN_UTF8;
10195
10196         /* This string is just a short named one above \xff */
10197         toFOLD_utf8_safe(hyphen, hyphen + sizeof(hyphen) - 1, dummy, NULL);
10198         assert(PL_utf8_tofold); /* Verify that worked */
10199     }
10200     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10201 }
10202 #endif
10203
10204 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10205 bool
10206 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10207 {
10208     /* Return a boolean as to if the two passed in inversion lists are
10209      * identical.  The final argument, if TRUE, says to take the complement of
10210      * the second inversion list before doing the comparison */
10211
10212     const UV* array_a = invlist_array(a);
10213     const UV* array_b = invlist_array(b);
10214     UV len_a = _invlist_len(a);
10215     UV len_b = _invlist_len(b);
10216
10217     PERL_ARGS_ASSERT__INVLISTEQ;
10218
10219     /* If are to compare 'a' with the complement of b, set it
10220      * up so are looking at b's complement. */
10221     if (complement_b) {
10222
10223         /* The complement of nothing is everything, so <a> would have to have
10224          * just one element, starting at zero (ending at infinity) */
10225         if (len_b == 0) {
10226             return (len_a == 1 && array_a[0] == 0);
10227         }
10228         else if (array_b[0] == 0) {
10229
10230             /* Otherwise, to complement, we invert.  Here, the first element is
10231              * 0, just remove it.  To do this, we just pretend the array starts
10232              * one later */
10233
10234             array_b++;
10235             len_b--;
10236         }
10237         else {
10238
10239             /* But if the first element is not zero, we pretend the list starts
10240              * at the 0 that is always stored immediately before the array. */
10241             array_b--;
10242             len_b++;
10243         }
10244     }
10245
10246     return    len_a == len_b
10247            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10248
10249 }
10250 #endif
10251
10252 /*
10253  * As best we can, determine the characters that can match the start of
10254  * the given EXACTF-ish node.
10255  *
10256  * Returns the invlist as a new SV*; it is the caller's responsibility to
10257  * call SvREFCNT_dec() when done with it.
10258  */
10259 STATIC SV*
10260 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10261 {
10262     const U8 * s = (U8*)STRING(node);
10263     SSize_t bytelen = STR_LEN(node);
10264     UV uc;
10265     /* Start out big enough for 2 separate code points */
10266     SV* invlist = _new_invlist(4);
10267
10268     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10269
10270     if (! UTF) {
10271         uc = *s;
10272
10273         /* We punt and assume can match anything if the node begins
10274          * with a multi-character fold.  Things are complicated.  For
10275          * example, /ffi/i could match any of:
10276          *  "\N{LATIN SMALL LIGATURE FFI}"
10277          *  "\N{LATIN SMALL LIGATURE FF}I"
10278          *  "F\N{LATIN SMALL LIGATURE FI}"
10279          *  plus several other things; and making sure we have all the
10280          *  possibilities is hard. */
10281         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10282             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10283         }
10284         else {
10285             /* Any Latin1 range character can potentially match any
10286              * other depending on the locale */
10287             if (OP(node) == EXACTFL) {
10288                 _invlist_union(invlist, PL_Latin1, &invlist);
10289             }
10290             else {
10291                 /* But otherwise, it matches at least itself.  We can
10292                  * quickly tell if it has a distinct fold, and if so,
10293                  * it matches that as well */
10294                 invlist = add_cp_to_invlist(invlist, uc);
10295                 if (IS_IN_SOME_FOLD_L1(uc))
10296                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10297             }
10298
10299             /* Some characters match above-Latin1 ones under /i.  This
10300              * is true of EXACTFL ones when the locale is UTF-8 */
10301             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10302                 && (! isASCII(uc) || (OP(node) != EXACTFAA
10303                                     && OP(node) != EXACTFAA_NO_TRIE)))
10304             {
10305                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10306             }
10307         }
10308     }
10309     else {  /* Pattern is UTF-8 */
10310         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10311         STRLEN foldlen = UTF8SKIP(s);
10312         const U8* e = s + bytelen;
10313         SV** listp;
10314
10315         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10316
10317         /* The only code points that aren't folded in a UTF EXACTFish
10318          * node are are the problematic ones in EXACTFL nodes */
10319         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10320             /* We need to check for the possibility that this EXACTFL
10321              * node begins with a multi-char fold.  Therefore we fold
10322              * the first few characters of it so that we can make that
10323              * check */
10324             U8 *d = folded;
10325             int i;
10326
10327             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10328                 if (isASCII(*s)) {
10329                     *(d++) = (U8) toFOLD(*s);
10330                     s++;
10331                 }
10332                 else {
10333                     STRLEN len;
10334                     toFOLD_utf8_safe(s, e, d, &len);
10335                     d += len;
10336                     s += UTF8SKIP(s);
10337                 }
10338             }
10339
10340             /* And set up so the code below that looks in this folded
10341              * buffer instead of the node's string */
10342             e = d;
10343             foldlen = UTF8SKIP(folded);
10344             s = folded;
10345         }
10346
10347         /* When we reach here 's' points to the fold of the first
10348          * character(s) of the node; and 'e' points to far enough along
10349          * the folded string to be just past any possible multi-char
10350          * fold. 'foldlen' is the length in bytes of the first
10351          * character in 's'
10352          *
10353          * Unlike the non-UTF-8 case, the macro for determining if a
10354          * string is a multi-char fold requires all the characters to
10355          * already be folded.  This is because of all the complications
10356          * if not.  Note that they are folded anyway, except in EXACTFL
10357          * nodes.  Like the non-UTF case above, we punt if the node
10358          * begins with a multi-char fold  */
10359
10360         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10361             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10362         }
10363         else {  /* Single char fold */
10364
10365             /* It matches all the things that fold to it, which are
10366              * found in PL_utf8_foldclosures (including itself) */
10367             invlist = add_cp_to_invlist(invlist, uc);
10368             if (! PL_utf8_foldclosures)
10369                 _load_PL_utf8_foldclosures();
10370             if ((listp = hv_fetch(PL_utf8_foldclosures,
10371                                 (char *) s, foldlen, FALSE)))
10372             {
10373                 AV* list = (AV*) *listp;
10374                 IV k;
10375                 for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
10376                     SV** c_p = av_fetch(list, k, FALSE);
10377                     UV c;
10378                     assert(c_p);
10379
10380                     c = SvUV(*c_p);
10381
10382                     /* /aa doesn't allow folds between ASCII and non- */
10383                     if ((OP(node) == EXACTFAA || OP(node) == EXACTFAA_NO_TRIE)
10384                         && isASCII(c) != isASCII(uc))
10385                     {
10386                         continue;
10387                     }
10388
10389                     invlist = add_cp_to_invlist(invlist, c);
10390                 }
10391             }
10392         }
10393     }
10394
10395     return invlist;
10396 }
10397
10398 #undef HEADER_LENGTH
10399 #undef TO_INTERNAL_SIZE
10400 #undef FROM_INTERNAL_SIZE
10401 #undef INVLIST_VERSION_ID
10402
10403 /* End of inversion list object */
10404
10405 STATIC void
10406 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10407 {
10408     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10409      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10410      * should point to the first flag; it is updated on output to point to the
10411      * final ')' or ':'.  There needs to be at least one flag, or this will
10412      * abort */
10413
10414     /* for (?g), (?gc), and (?o) warnings; warning
10415        about (?c) will warn about (?g) -- japhy    */
10416
10417 #define WASTED_O  0x01
10418 #define WASTED_G  0x02
10419 #define WASTED_C  0x04
10420 #define WASTED_GC (WASTED_G|WASTED_C)
10421     I32 wastedflags = 0x00;
10422     U32 posflags = 0, negflags = 0;
10423     U32 *flagsp = &posflags;
10424     char has_charset_modifier = '\0';
10425     regex_charset cs;
10426     bool has_use_defaults = FALSE;
10427     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10428     int x_mod_count = 0;
10429
10430     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10431
10432     /* '^' as an initial flag sets certain defaults */
10433     if (UCHARAT(RExC_parse) == '^') {
10434         RExC_parse++;
10435         has_use_defaults = TRUE;
10436         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10437         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10438                                         ? REGEX_UNICODE_CHARSET
10439                                         : REGEX_DEPENDS_CHARSET);
10440     }
10441
10442     cs = get_regex_charset(RExC_flags);
10443     if (cs == REGEX_DEPENDS_CHARSET
10444         && (RExC_utf8 || RExC_uni_semantics))
10445     {
10446         cs = REGEX_UNICODE_CHARSET;
10447     }
10448
10449     while (RExC_parse < RExC_end) {
10450         /* && strchr("iogcmsx", *RExC_parse) */
10451         /* (?g), (?gc) and (?o) are useless here
10452            and must be globally applied -- japhy */
10453         switch (*RExC_parse) {
10454
10455             /* Code for the imsxn flags */
10456             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10457
10458             case LOCALE_PAT_MOD:
10459                 if (has_charset_modifier) {
10460                     goto excess_modifier;
10461                 }
10462                 else if (flagsp == &negflags) {
10463                     goto neg_modifier;
10464                 }
10465                 cs = REGEX_LOCALE_CHARSET;
10466                 has_charset_modifier = LOCALE_PAT_MOD;
10467                 break;
10468             case UNICODE_PAT_MOD:
10469                 if (has_charset_modifier) {
10470                     goto excess_modifier;
10471                 }
10472                 else if (flagsp == &negflags) {
10473                     goto neg_modifier;
10474                 }
10475                 cs = REGEX_UNICODE_CHARSET;
10476                 has_charset_modifier = UNICODE_PAT_MOD;
10477                 break;
10478             case ASCII_RESTRICT_PAT_MOD:
10479                 if (flagsp == &negflags) {
10480                     goto neg_modifier;
10481                 }
10482                 if (has_charset_modifier) {
10483                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10484                         goto excess_modifier;
10485                     }
10486                     /* Doubled modifier implies more restricted */
10487                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10488                 }
10489                 else {
10490                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10491                 }
10492                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10493                 break;
10494             case DEPENDS_PAT_MOD:
10495                 if (has_use_defaults) {
10496                     goto fail_modifiers;
10497                 }
10498                 else if (flagsp == &negflags) {
10499                     goto neg_modifier;
10500                 }
10501                 else if (has_charset_modifier) {
10502                     goto excess_modifier;
10503                 }
10504
10505                 /* The dual charset means unicode semantics if the
10506                  * pattern (or target, not known until runtime) are
10507                  * utf8, or something in the pattern indicates unicode
10508                  * semantics */
10509                 cs = (RExC_utf8 || RExC_uni_semantics)
10510                      ? REGEX_UNICODE_CHARSET
10511                      : REGEX_DEPENDS_CHARSET;
10512                 has_charset_modifier = DEPENDS_PAT_MOD;
10513                 break;
10514               excess_modifier:
10515                 RExC_parse++;
10516                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10517                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10518                 }
10519                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10520                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10521                                         *(RExC_parse - 1));
10522                 }
10523                 else {
10524                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10525                 }
10526                 NOT_REACHED; /*NOTREACHED*/
10527               neg_modifier:
10528                 RExC_parse++;
10529                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10530                                     *(RExC_parse - 1));
10531                 NOT_REACHED; /*NOTREACHED*/
10532             case ONCE_PAT_MOD: /* 'o' */
10533             case GLOBAL_PAT_MOD: /* 'g' */
10534                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10535                     const I32 wflagbit = *RExC_parse == 'o'
10536                                          ? WASTED_O
10537                                          : WASTED_G;
10538                     if (! (wastedflags & wflagbit) ) {
10539                         wastedflags |= wflagbit;
10540                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10541                         vWARN5(
10542                             RExC_parse + 1,
10543                             "Useless (%s%c) - %suse /%c modifier",
10544                             flagsp == &negflags ? "?-" : "?",
10545                             *RExC_parse,
10546                             flagsp == &negflags ? "don't " : "",
10547                             *RExC_parse
10548                         );
10549                     }
10550                 }
10551                 break;
10552
10553             case CONTINUE_PAT_MOD: /* 'c' */
10554                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10555                     if (! (wastedflags & WASTED_C) ) {
10556                         wastedflags |= WASTED_GC;
10557                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10558                         vWARN3(
10559                             RExC_parse + 1,
10560                             "Useless (%sc) - %suse /gc modifier",
10561                             flagsp == &negflags ? "?-" : "?",
10562                             flagsp == &negflags ? "don't " : ""
10563                         );
10564                     }
10565                 }
10566                 break;
10567             case KEEPCOPY_PAT_MOD: /* 'p' */
10568                 if (flagsp == &negflags) {
10569                     if (PASS2)
10570                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10571                 } else {
10572                     *flagsp |= RXf_PMf_KEEPCOPY;
10573                 }
10574                 break;
10575             case '-':
10576                 /* A flag is a default iff it is following a minus, so
10577                  * if there is a minus, it means will be trying to
10578                  * re-specify a default which is an error */
10579                 if (has_use_defaults || flagsp == &negflags) {
10580                     goto fail_modifiers;
10581                 }
10582                 flagsp = &negflags;
10583                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10584                 x_mod_count = 0;
10585                 break;
10586             case ':':
10587             case ')':
10588
10589                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
10590                     negflags |= RXf_PMf_EXTENDED_MORE;
10591                 }
10592                 RExC_flags |= posflags;
10593
10594                 if (negflags & RXf_PMf_EXTENDED) {
10595                     negflags |= RXf_PMf_EXTENDED_MORE;
10596                 }
10597                 RExC_flags &= ~negflags;
10598                 set_regex_charset(&RExC_flags, cs);
10599
10600                 return;
10601             default:
10602               fail_modifiers:
10603                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10604                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10605                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10606                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10607                 NOT_REACHED; /*NOTREACHED*/
10608         }
10609
10610         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10611     }
10612
10613     vFAIL("Sequence (?... not terminated");
10614 }
10615
10616 /*
10617  - reg - regular expression, i.e. main body or parenthesized thing
10618  *
10619  * Caller must absorb opening parenthesis.
10620  *
10621  * Combining parenthesis handling with the base level of regular expression
10622  * is a trifle forced, but the need to tie the tails of the branches to what
10623  * follows makes it hard to avoid.
10624  */
10625 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10626 #ifdef DEBUGGING
10627 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10628 #else
10629 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10630 #endif
10631
10632 PERL_STATIC_INLINE regnode *
10633 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10634                              I32 *flagp,
10635                              char * parse_start,
10636                              char ch
10637                       )
10638 {
10639     regnode *ret;
10640     char* name_start = RExC_parse;
10641     U32 num = 0;
10642     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10643                                             ? REG_RSN_RETURN_NULL
10644                                             : REG_RSN_RETURN_DATA);
10645     GET_RE_DEBUG_FLAGS_DECL;
10646
10647     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10648
10649     if (RExC_parse == name_start || *RExC_parse != ch) {
10650         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10651         vFAIL2("Sequence %.3s... not terminated",parse_start);
10652     }
10653
10654     if (!SIZE_ONLY) {
10655         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10656         RExC_rxi->data->data[num]=(void*)sv_dat;
10657         SvREFCNT_inc_simple_void(sv_dat);
10658     }
10659     RExC_sawback = 1;
10660     ret = reganode(pRExC_state,
10661                    ((! FOLD)
10662                      ? NREF
10663                      : (ASCII_FOLD_RESTRICTED)
10664                        ? NREFFA
10665                        : (AT_LEAST_UNI_SEMANTICS)
10666                          ? NREFFU
10667                          : (LOC)
10668                            ? NREFFL
10669                            : NREFF),
10670                     num);
10671     *flagp |= HASWIDTH;
10672
10673     Set_Node_Offset(ret, parse_start+1);
10674     Set_Node_Cur_Length(ret, parse_start);
10675
10676     nextchar(pRExC_state);
10677     return ret;
10678 }
10679
10680 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10681    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10682    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10683    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10684    NULL, which cannot happen.  */
10685 STATIC regnode *
10686 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10687     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10688      * 2 is like 1, but indicates that nextchar() has been called to advance
10689      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10690      * this flag alerts us to the need to check for that */
10691 {
10692     regnode *ret = NULL;    /* Will be the head of the group. */
10693     regnode *br;
10694     regnode *lastbr;
10695     regnode *ender = NULL;
10696     I32 parno = 0;
10697     I32 flags;
10698     U32 oregflags = RExC_flags;
10699     bool have_branch = 0;
10700     bool is_open = 0;
10701     I32 freeze_paren = 0;
10702     I32 after_freeze = 0;
10703     I32 num; /* numeric backreferences */
10704
10705     char * parse_start = RExC_parse; /* MJD */
10706     char * const oregcomp_parse = RExC_parse;
10707
10708     GET_RE_DEBUG_FLAGS_DECL;
10709
10710     PERL_ARGS_ASSERT_REG;
10711     DEBUG_PARSE("reg ");
10712
10713     *flagp = 0;                         /* Tentatively. */
10714
10715     /* Having this true makes it feasible to have a lot fewer tests for the
10716      * parse pointer being in scope.  For example, we can write
10717      *      while(isFOO(*RExC_parse)) RExC_parse++;
10718      * instead of
10719      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10720      */
10721     assert(*RExC_end == '\0');
10722
10723     /* Make an OPEN node, if parenthesized. */
10724     if (paren) {
10725
10726         /* Under /x, space and comments can be gobbled up between the '(' and
10727          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10728          * intervening space, as the sequence is a token, and a token should be
10729          * indivisible */
10730         bool has_intervening_patws = (paren == 2)
10731                                   && *(RExC_parse - 1) != '(';
10732
10733         if (RExC_parse >= RExC_end) {
10734             vFAIL("Unmatched (");
10735         }
10736
10737         if (paren == 'r') {     /* Atomic script run */
10738             paren = '>';
10739             goto parse_rest;
10740         }
10741         else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */
10742             char *start_verb = RExC_parse + 1;
10743             STRLEN verb_len;
10744             char *start_arg = NULL;
10745             unsigned char op = 0;
10746             int arg_required = 0;
10747             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10748             bool has_upper = FALSE;
10749
10750             if (has_intervening_patws) {
10751                 RExC_parse++;   /* past the '*' */
10752
10753                 /* For strict backwards compatibility, don't change the message
10754                  * now that we also have lowercase operands */
10755                 if (isUPPER(*RExC_parse)) {
10756                     vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10757                 }
10758                 else {
10759                     vFAIL("In '(*...)', the '(' and '*' must be adjacent");
10760                 }
10761             }
10762             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10763                 if ( *RExC_parse == ':' ) {
10764                     start_arg = RExC_parse + 1;
10765                     break;
10766                 }
10767                 else if (! UTF) {
10768                     if (isUPPER(*RExC_parse)) {
10769                         has_upper = TRUE;
10770                     }
10771                     RExC_parse++;
10772                 }
10773                 else {
10774                     RExC_parse += UTF8SKIP(RExC_parse);
10775                 }
10776             }
10777             verb_len = RExC_parse - start_verb;
10778             if ( start_arg ) {
10779                 if (RExC_parse >= RExC_end) {
10780                     goto unterminated_verb_pattern;
10781                 }
10782
10783                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10784                 while ( RExC_parse < RExC_end && *RExC_parse != ')' ) {
10785                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10786                 }
10787                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
10788                   unterminated_verb_pattern:
10789                     if (has_upper) {
10790                         vFAIL("Unterminated verb pattern argument");
10791                     }
10792                     else {
10793                         vFAIL("Unterminated '(*...' argument");
10794                     }
10795                 }
10796             } else {
10797                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
10798                     if (has_upper) {
10799                         vFAIL("Unterminated verb pattern");
10800                     }
10801                     else {
10802                         vFAIL("Unterminated '(*...' construct");
10803                     }
10804                 }
10805             }
10806
10807             /* Here, we know that RExC_parse < RExC_end */
10808
10809             switch ( *start_verb ) {
10810             case 'A':  /* (*ACCEPT) */
10811                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10812                     op = ACCEPT;
10813                     internal_argval = RExC_nestroot;
10814                 }
10815                 break;
10816             case 'C':  /* (*COMMIT) */
10817                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10818                     op = COMMIT;
10819                 break;
10820             case 'F':  /* (*FAIL) */
10821                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10822                     op = OPFAIL;
10823                 }
10824                 break;
10825             case ':':  /* (*:NAME) */
10826             case 'M':  /* (*MARK:NAME) */
10827                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10828                     op = MARKPOINT;
10829                     arg_required = 1;
10830                 }
10831                 break;
10832             case 'P':  /* (*PRUNE) */
10833                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10834                     op = PRUNE;
10835                 break;
10836             case 'S':   /* (*SKIP) */
10837                 if ( memEQs(start_verb,verb_len,"SKIP") )
10838                     op = SKIP;
10839                 break;
10840             case 'T':  /* (*THEN) */
10841                 /* [19:06] <TimToady> :: is then */
10842                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10843                     op = CUTGROUP;
10844                     RExC_seen |= REG_CUTGROUP_SEEN;
10845                 }
10846                 break;
10847             case 'a':
10848                 if (   memEQs(start_verb, verb_len, "asr")
10849                     || memEQs(start_verb, verb_len, "atomic_script_run"))
10850                 {
10851                     paren = 'r';        /* Mnemonic: recursed run */
10852                     goto script_run;
10853                 }
10854                 else if (memEQs(start_verb, verb_len, "atomic")) {
10855                     paren = 't';    /* AtOMIC */
10856                     goto alpha_assertions;
10857                 }
10858                 break;
10859             case 'p':
10860                 if (   memEQs(start_verb, verb_len, "plb")
10861                     || memEQs(start_verb, verb_len, "positive_lookbehind"))
10862                 {
10863                     paren = 'b';
10864                     goto lookbehind_alpha_assertions;
10865                 }
10866                 else if (   memEQs(start_verb, verb_len, "pla")
10867                          || memEQs(start_verb, verb_len, "positive_lookahead"))
10868                 {
10869                     paren = 'a';
10870                     goto alpha_assertions;
10871                 }
10872                 break;
10873             case 'n':
10874                 if (   memEQs(start_verb, verb_len, "nlb")
10875                     || memEQs(start_verb, verb_len, "negative_lookbehind"))
10876                 {
10877                     paren = 'B';
10878                     goto lookbehind_alpha_assertions;
10879                 }
10880                 else if (   memEQs(start_verb, verb_len, "nla")
10881                          || memEQs(start_verb, verb_len, "negative_lookahead"))
10882                 {
10883                     paren = 'A';
10884                     goto alpha_assertions;
10885                 }
10886                 break;
10887             case 's':
10888                 if (   memEQs(start_verb, verb_len, "sr")
10889                     || memEQs(start_verb, verb_len, "script_run"))
10890                 {
10891                     regnode * atomic;
10892
10893                     paren = 's';
10894
10895                    script_run:
10896
10897                     /* This indicates Unicode rules. */
10898                     REQUIRE_UNI_RULES(flagp, NULL);
10899
10900                     if (! start_arg) {
10901                         goto no_colon;
10902                     }
10903
10904                     RExC_parse = start_arg;
10905
10906                     if (RExC_in_script_run) {
10907
10908                         /*  Nested script runs are treated as no-ops, because
10909                          *  if the nested one fails, the outer one must as
10910                          *  well.  It could fail sooner, and avoid (??{} with
10911                          *  side effects, but that is explicitly documented as
10912                          *  undefined behavior. */
10913
10914                         ret = NULL;
10915
10916                         if (paren == 's') {
10917                             paren = ':';
10918                             goto parse_rest;
10919                         }
10920
10921                         /* But, the atomic part of a nested atomic script run
10922                          * isn't a no-op, but can be treated just like a '(?>'
10923                          * */
10924                         paren = '>';
10925                         goto parse_rest;
10926                     }
10927
10928                     /* By doing this here, we avoid extra warnings for nested
10929                      * script runs */
10930                     if (PASS2) {
10931                         Perl_ck_warner_d(aTHX_
10932                             packWARN(WARN_EXPERIMENTAL__SCRIPT_RUN),
10933                             "The script_run feature is experimental"
10934                             REPORT_LOCATION, REPORT_LOCATION_ARGS(RExC_parse));
10935
10936                     }
10937
10938                     if (paren == 's') {
10939                         /* Here, we're starting a new regular script run */
10940                         ret = reg_node(pRExC_state, SROPEN);
10941                         RExC_in_script_run = 1;
10942                         is_open = 1;
10943                         goto parse_rest;
10944                     }
10945
10946                     /* Here, we are starting an atomic script run.  This is
10947                      * handled by recursing to deal with the atomic portion
10948                      * separately, enclosed in SROPEN ... SRCLOSE nodes */
10949
10950                     ret = reg_node(pRExC_state, SROPEN);
10951
10952                     RExC_in_script_run = 1;
10953
10954                     atomic = reg(pRExC_state, 'r', &flags, depth);
10955                     if (flags & (RESTART_PASS1|NEED_UTF8)) {
10956                         *flagp = flags & (RESTART_PASS1|NEED_UTF8);
10957                         return NULL;
10958                     }
10959
10960                     REGTAIL(pRExC_state, ret, atomic);
10961
10962                     REGTAIL(pRExC_state, atomic,
10963                            reg_node(pRExC_state, SRCLOSE));
10964
10965                     RExC_in_script_run = 0;
10966                     return ret;
10967                 }
10968
10969                 break;
10970
10971             lookbehind_alpha_assertions:
10972                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10973                 RExC_in_lookbehind++;
10974                 /*FALLTHROUGH*/
10975
10976             alpha_assertions:
10977
10978                 if (PASS2) {
10979                     Perl_ck_warner_d(aTHX_
10980                         packWARN(WARN_EXPERIMENTAL__ALPHA_ASSERTIONS),
10981                         "The alpha_assertions feature is experimental"
10982                         REPORT_LOCATION, REPORT_LOCATION_ARGS(RExC_parse));
10983                 }
10984
10985                 RExC_seen_zerolen++;
10986
10987                 if (! start_arg) {
10988                     goto no_colon;
10989                 }
10990
10991                 /* An empty negative lookahead assertion simply is failure */
10992                 if (paren == 'A' && RExC_parse == start_arg) {
10993                     ret=reganode(pRExC_state, OPFAIL, 0);
10994                     nextchar(pRExC_state);
10995                     return ret;
10996                 }
10997
10998                 RExC_parse = start_arg;
10999                 goto parse_rest;
11000
11001               no_colon:
11002                 vFAIL2utf8f(
11003                 "'(*%" UTF8f "' requires a terminating ':'",
11004                 UTF8fARG(UTF, verb_len, start_verb));
11005                 NOT_REACHED; /*NOTREACHED*/
11006
11007             } /* End of switch */
11008             if ( ! op ) {
11009                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11010                 if (has_upper || verb_len == 0) {
11011                     vFAIL2utf8f(
11012                     "Unknown verb pattern '%" UTF8f "'",
11013                     UTF8fARG(UTF, verb_len, start_verb));
11014                 }
11015                 else {
11016                     vFAIL2utf8f(
11017                     "Unknown '(*...)' construct '%" UTF8f "'",
11018                     UTF8fARG(UTF, verb_len, start_verb));
11019                 }
11020             }
11021             if ( RExC_parse == start_arg ) {
11022                 start_arg = NULL;
11023             }
11024             if ( arg_required && !start_arg ) {
11025                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
11026                     verb_len, start_verb);
11027             }
11028             if (internal_argval == -1) {
11029                 ret = reganode(pRExC_state, op, 0);
11030             } else {
11031                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
11032             }
11033             RExC_seen |= REG_VERBARG_SEEN;
11034             if ( ! SIZE_ONLY ) {
11035                 if (start_arg) {
11036                     SV *sv = newSVpvn( start_arg,
11037                                        RExC_parse - start_arg);
11038                     ARG(ret) = add_data( pRExC_state,
11039                                          STR_WITH_LEN("S"));
11040                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
11041                     ret->flags = 1;
11042                 } else {
11043                     ret->flags = 0;
11044                 }
11045                 if ( internal_argval != -1 )
11046                     ARG2L_SET(ret, internal_argval);
11047             }
11048             nextchar(pRExC_state);
11049             return ret;
11050         }
11051         else if (*RExC_parse == '?') { /* (?...) */
11052             bool is_logical = 0;
11053             const char * const seqstart = RExC_parse;
11054             const char * endptr;
11055             if (has_intervening_patws) {
11056                 RExC_parse++;
11057                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
11058             }
11059
11060             RExC_parse++;           /* past the '?' */
11061             paren = *RExC_parse;    /* might be a trailing NUL, if not
11062                                        well-formed */
11063             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11064             if (RExC_parse > RExC_end) {
11065                 paren = '\0';
11066             }
11067             ret = NULL;                 /* For look-ahead/behind. */
11068             switch (paren) {
11069
11070             case 'P':   /* (?P...) variants for those used to PCRE/Python */
11071                 paren = *RExC_parse;
11072                 if ( paren == '<') {    /* (?P<...>) named capture */
11073                     RExC_parse++;
11074                     if (RExC_parse >= RExC_end) {
11075                         vFAIL("Sequence (?P<... not terminated");
11076                     }
11077                     goto named_capture;
11078                 }
11079                 else if (paren == '>') {   /* (?P>name) named recursion */
11080                     RExC_parse++;
11081                     if (RExC_parse >= RExC_end) {
11082                         vFAIL("Sequence (?P>... not terminated");
11083                     }
11084                     goto named_recursion;
11085                 }
11086                 else if (paren == '=') {   /* (?P=...)  named backref */
11087                     RExC_parse++;
11088                     return handle_named_backref(pRExC_state, flagp,
11089                                                 parse_start, ')');
11090                 }
11091                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
11092                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11093                 vFAIL3("Sequence (%.*s...) not recognized",
11094                                 RExC_parse-seqstart, seqstart);
11095                 NOT_REACHED; /*NOTREACHED*/
11096             case '<':           /* (?<...) */
11097                 if (*RExC_parse == '!')
11098                     paren = ',';
11099                 else if (*RExC_parse != '=')
11100               named_capture:
11101                 {               /* (?<...>) */
11102                     char *name_start;
11103                     SV *svname;
11104                     paren= '>';
11105                 /* FALLTHROUGH */
11106             case '\'':          /* (?'...') */
11107                     name_start = RExC_parse;
11108                     svname = reg_scan_name(pRExC_state,
11109                         SIZE_ONLY    /* reverse test from the others */
11110                         ? REG_RSN_RETURN_NAME
11111                         : REG_RSN_RETURN_NULL);
11112                     if (   RExC_parse == name_start
11113                         || RExC_parse >= RExC_end
11114                         || *RExC_parse != paren)
11115                     {
11116                         vFAIL2("Sequence (?%c... not terminated",
11117                             paren=='>' ? '<' : paren);
11118                     }
11119                     if (SIZE_ONLY) {
11120                         HE *he_str;
11121                         SV *sv_dat = NULL;
11122                         if (!svname) /* shouldn't happen */
11123                             Perl_croak(aTHX_
11124                                 "panic: reg_scan_name returned NULL");
11125                         if (!RExC_paren_names) {
11126                             RExC_paren_names= newHV();
11127                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
11128 #ifdef DEBUGGING
11129                             RExC_paren_name_list= newAV();
11130                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
11131 #endif
11132                         }
11133                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
11134                         if ( he_str )
11135                             sv_dat = HeVAL(he_str);
11136                         if ( ! sv_dat ) {
11137                             /* croak baby croak */
11138                             Perl_croak(aTHX_
11139                                 "panic: paren_name hash element allocation failed");
11140                         } else if ( SvPOK(sv_dat) ) {
11141                             /* (?|...) can mean we have dupes so scan to check
11142                                its already been stored. Maybe a flag indicating
11143                                we are inside such a construct would be useful,
11144                                but the arrays are likely to be quite small, so
11145                                for now we punt -- dmq */
11146                             IV count = SvIV(sv_dat);
11147                             I32 *pv = (I32*)SvPVX(sv_dat);
11148                             IV i;
11149                             for ( i = 0 ; i < count ; i++ ) {
11150                                 if ( pv[i] == RExC_npar ) {
11151                                     count = 0;
11152                                     break;
11153                                 }
11154                             }
11155                             if ( count ) {
11156                                 pv = (I32*)SvGROW(sv_dat,
11157                                                 SvCUR(sv_dat) + sizeof(I32)+1);
11158                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
11159                                 pv[count] = RExC_npar;
11160                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
11161                             }
11162                         } else {
11163                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
11164                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
11165                                                                 sizeof(I32));
11166                             SvIOK_on(sv_dat);
11167                             SvIV_set(sv_dat, 1);
11168                         }
11169 #ifdef DEBUGGING
11170                         /* Yes this does cause a memory leak in debugging Perls
11171                          * */
11172                         if (!av_store(RExC_paren_name_list,
11173                                       RExC_npar, SvREFCNT_inc(svname)))
11174                             SvREFCNT_dec_NN(svname);
11175 #endif
11176
11177                         /*sv_dump(sv_dat);*/
11178                     }
11179                     nextchar(pRExC_state);
11180                     paren = 1;
11181                     goto capturing_parens;
11182                 }
11183
11184                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11185                 RExC_in_lookbehind++;
11186                 RExC_parse++;
11187                 if (RExC_parse >= RExC_end) {
11188                     vFAIL("Sequence (?... not terminated");
11189                 }
11190
11191                 /* FALLTHROUGH */
11192             case '=':           /* (?=...) */
11193                 RExC_seen_zerolen++;
11194                 break;
11195             case '!':           /* (?!...) */
11196                 RExC_seen_zerolen++;
11197                 /* check if we're really just a "FAIL" assertion */
11198                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11199                                         FALSE /* Don't force to /x */ );
11200                 if (*RExC_parse == ')') {
11201                     ret=reganode(pRExC_state, OPFAIL, 0);
11202                     nextchar(pRExC_state);
11203                     return ret;
11204                 }
11205                 break;
11206             case '|':           /* (?|...) */
11207                 /* branch reset, behave like a (?:...) except that
11208                    buffers in alternations share the same numbers */
11209                 paren = ':';
11210                 after_freeze = freeze_paren = RExC_npar;
11211                 break;
11212             case ':':           /* (?:...) */
11213             case '>':           /* (?>...) */
11214                 break;
11215             case '$':           /* (?$...) */
11216             case '@':           /* (?@...) */
11217                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
11218                 break;
11219             case '0' :           /* (?0) */
11220             case 'R' :           /* (?R) */
11221                 if (RExC_parse == RExC_end || *RExC_parse != ')')
11222                     FAIL("Sequence (?R) not terminated");
11223                 num = 0;
11224                 RExC_seen |= REG_RECURSE_SEEN;
11225                 *flagp |= POSTPONED;
11226                 goto gen_recurse_regop;
11227                 /*notreached*/
11228             /* named and numeric backreferences */
11229             case '&':            /* (?&NAME) */
11230                 parse_start = RExC_parse - 1;
11231               named_recursion:
11232                 {
11233                     SV *sv_dat = reg_scan_name(pRExC_state,
11234                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11235                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
11236                 }
11237                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
11238                     vFAIL("Sequence (?&... not terminated");
11239                 goto gen_recurse_regop;
11240                 /* NOTREACHED */
11241             case '+':
11242                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
11243                     RExC_parse++;
11244                     vFAIL("Illegal pattern");
11245                 }
11246                 goto parse_recursion;
11247                 /* NOTREACHED*/
11248             case '-': /* (?-1) */
11249                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
11250                     RExC_parse--; /* rewind to let it be handled later */
11251                     goto parse_flags;
11252                 }
11253                 /* FALLTHROUGH */
11254             case '1': case '2': case '3': case '4': /* (?1) */
11255             case '5': case '6': case '7': case '8': case '9':
11256                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
11257               parse_recursion:
11258                 {
11259                     bool is_neg = FALSE;
11260                     UV unum;
11261                     parse_start = RExC_parse - 1; /* MJD */
11262                     if (*RExC_parse == '-') {
11263                         RExC_parse++;
11264                         is_neg = TRUE;
11265                     }
11266                     if (grok_atoUV(RExC_parse, &unum, &endptr)
11267                         && unum <= I32_MAX
11268                     ) {
11269                         num = (I32)unum;
11270                         RExC_parse = (char*)endptr;
11271                     } else
11272                         num = I32_MAX;
11273                     if (is_neg) {
11274                         /* Some limit for num? */
11275                         num = -num;
11276                     }
11277                 }
11278                 if (*RExC_parse!=')')
11279                     vFAIL("Expecting close bracket");
11280
11281               gen_recurse_regop:
11282                 if ( paren == '-' ) {
11283                     /*
11284                     Diagram of capture buffer numbering.
11285                     Top line is the normal capture buffer numbers
11286                     Bottom line is the negative indexing as from
11287                     the X (the (?-2))
11288
11289                     +   1 2    3 4 5 X          6 7
11290                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
11291                     -   5 4    3 2 1 X          x x
11292
11293                     */
11294                     num = RExC_npar + num;
11295                     if (num < 1)  {
11296                         RExC_parse++;
11297                         vFAIL("Reference to nonexistent group");
11298                     }
11299                 } else if ( paren == '+' ) {
11300                     num = RExC_npar + num - 1;
11301                 }
11302                 /* We keep track how many GOSUB items we have produced.
11303                    To start off the ARG2L() of the GOSUB holds its "id",
11304                    which is used later in conjunction with RExC_recurse
11305                    to calculate the offset we need to jump for the GOSUB,
11306                    which it will store in the final representation.
11307                    We have to defer the actual calculation until much later
11308                    as the regop may move.
11309                  */
11310
11311                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
11312                 if (!SIZE_ONLY) {
11313                     if (num > (I32)RExC_rx->nparens) {
11314                         RExC_parse++;
11315                         vFAIL("Reference to nonexistent group");
11316                     }
11317                     RExC_recurse_count++;
11318                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11319                         "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
11320                               22, "|    |", (int)(depth * 2 + 1), "",
11321                               (UV)ARG(ret), (IV)ARG2L(ret)));
11322                 }
11323                 RExC_seen |= REG_RECURSE_SEEN;
11324
11325                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
11326                 Set_Node_Offset(ret, parse_start); /* MJD */
11327
11328                 *flagp |= POSTPONED;
11329                 assert(*RExC_parse == ')');
11330                 nextchar(pRExC_state);
11331                 return ret;
11332
11333             /* NOTREACHED */
11334
11335             case '?':           /* (??...) */
11336                 is_logical = 1;
11337                 if (*RExC_parse != '{') {
11338                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
11339                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11340                     vFAIL2utf8f(
11341                         "Sequence (%" UTF8f "...) not recognized",
11342                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11343                     NOT_REACHED; /*NOTREACHED*/
11344                 }
11345                 *flagp |= POSTPONED;
11346                 paren = '{';
11347                 RExC_parse++;
11348                 /* FALLTHROUGH */
11349             case '{':           /* (?{...}) */
11350             {
11351                 U32 n = 0;
11352                 struct reg_code_block *cb;
11353
11354                 RExC_seen_zerolen++;
11355
11356                 if (   !pRExC_state->code_blocks
11357                     || pRExC_state->code_index
11358                                         >= pRExC_state->code_blocks->count
11359                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11360                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11361                             - RExC_start)
11362                 ) {
11363                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11364                         FAIL("panic: Sequence (?{...}): no code block found\n");
11365                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11366                 }
11367                 /* this is a pre-compiled code block (?{...}) */
11368                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11369                 RExC_parse = RExC_start + cb->end;
11370                 if (!SIZE_ONLY) {
11371                     OP *o = cb->block;
11372                     if (cb->src_regex) {
11373                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11374                         RExC_rxi->data->data[n] =
11375                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
11376                         RExC_rxi->data->data[n+1] = (void*)o;
11377                     }
11378                     else {
11379                         n = add_data(pRExC_state,
11380                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11381                         RExC_rxi->data->data[n] = (void*)o;
11382                     }
11383                 }
11384                 pRExC_state->code_index++;
11385                 nextchar(pRExC_state);
11386
11387                 if (is_logical) {
11388                     regnode *eval;
11389                     ret = reg_node(pRExC_state, LOGICAL);
11390
11391                     eval = reg2Lanode(pRExC_state, EVAL,
11392                                        n,
11393
11394                                        /* for later propagation into (??{})
11395                                         * return value */
11396                                        RExC_flags & RXf_PMf_COMPILETIME
11397                                       );
11398                     if (!SIZE_ONLY) {
11399                         ret->flags = 2;
11400                     }
11401                     REGTAIL(pRExC_state, ret, eval);
11402                     /* deal with the length of this later - MJD */
11403                     return ret;
11404                 }
11405                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11406                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
11407                 Set_Node_Offset(ret, parse_start);
11408                 return ret;
11409             }
11410             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11411             {
11412                 int is_define= 0;
11413                 const int DEFINE_len = sizeof("DEFINE") - 1;
11414                 if (    RExC_parse < RExC_end - 1
11415                     && (   (       RExC_parse[0] == '?'        /* (?(?...)) */
11416                             && (   RExC_parse[1] == '='
11417                                 || RExC_parse[1] == '!'
11418                                 || RExC_parse[1] == '<'
11419                                 || RExC_parse[1] == '{'))
11420                         || (       RExC_parse[0] == '*'        /* (?(*...)) */
11421                             && (   memBEGINs(RExC_parse + 1,
11422                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11423                                          "pla:")
11424                                 || memBEGINs(RExC_parse + 1,
11425                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11426                                          "plb:")
11427                                 || memBEGINs(RExC_parse + 1,
11428                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11429                                          "nla:")
11430                                 || memBEGINs(RExC_parse + 1,
11431                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11432                                          "nlb:")
11433                                 || memBEGINs(RExC_parse + 1,
11434                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11435                                          "positive_lookahead:")
11436                                 || memBEGINs(RExC_parse + 1,
11437                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11438                                          "positive_lookbehind:")
11439                                 || memBEGINs(RExC_parse + 1,
11440                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11441                                          "negative_lookahead:")
11442                                 || memBEGINs(RExC_parse + 1,
11443                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11444                                          "negative_lookbehind:"))))
11445                 ) { /* Lookahead or eval. */
11446                     I32 flag;
11447                     regnode *tail;
11448
11449                     ret = reg_node(pRExC_state, LOGICAL);
11450                     if (!SIZE_ONLY)
11451                         ret->flags = 1;
11452
11453                     tail = reg(pRExC_state, 1, &flag, depth+1);
11454                     RETURN_NULL_ON_RESTART(flag,flagp);
11455                     REGTAIL(pRExC_state, ret, tail);
11456                     goto insert_if;
11457                 }
11458                 else if (   RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11459                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11460                 {
11461                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11462                     char *name_start= RExC_parse++;
11463                     U32 num = 0;
11464                     SV *sv_dat=reg_scan_name(pRExC_state,
11465                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11466                     if (   RExC_parse == name_start
11467                         || RExC_parse >= RExC_end
11468                         || *RExC_parse != ch)
11469                     {
11470                         vFAIL2("Sequence (?(%c... not terminated",
11471                             (ch == '>' ? '<' : ch));
11472                     }
11473                     RExC_parse++;
11474                     if (!SIZE_ONLY) {
11475                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11476                         RExC_rxi->data->data[num]=(void*)sv_dat;
11477                         SvREFCNT_inc_simple_void(sv_dat);
11478                     }
11479                     ret = reganode(pRExC_state,NGROUPP,num);
11480                     goto insert_if_check_paren;
11481                 }
11482                 else if (memBEGINs(RExC_parse,
11483                                    (STRLEN) (RExC_end - RExC_parse),
11484                                    "DEFINE"))
11485                 {
11486                     ret = reganode(pRExC_state,DEFINEP,0);
11487                     RExC_parse += DEFINE_len;
11488                     is_define = 1;
11489                     goto insert_if_check_paren;
11490                 }
11491                 else if (RExC_parse[0] == 'R') {
11492                     RExC_parse++;
11493                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11494                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11495                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11496                      */
11497                     parno = 0;
11498                     if (RExC_parse[0] == '0') {
11499                         parno = 1;
11500                         RExC_parse++;
11501                     }
11502                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11503                         UV uv;
11504                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11505                             && uv <= I32_MAX
11506                         ) {
11507                             parno = (I32)uv + 1;
11508                             RExC_parse = (char*)endptr;
11509                         }
11510                         /* else "Switch condition not recognized" below */
11511                     } else if (RExC_parse[0] == '&') {
11512                         SV *sv_dat;
11513                         RExC_parse++;
11514                         sv_dat = reg_scan_name(pRExC_state,
11515                             SIZE_ONLY
11516                             ? REG_RSN_RETURN_NULL
11517                             : REG_RSN_RETURN_DATA);
11518
11519                         /* we should only have a false sv_dat when
11520                          * SIZE_ONLY is true, and we always have false
11521                          * sv_dat when SIZE_ONLY is true.
11522                          * reg_scan_name() will VFAIL() if the name is
11523                          * unknown when SIZE_ONLY is false, and otherwise
11524                          * will return something, and when SIZE_ONLY is
11525                          * true, reg_scan_name() just parses the string,
11526                          * and doesnt return anything. (in theory) */
11527                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
11528
11529                         if (sv_dat)
11530                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11531                     }
11532                     ret = reganode(pRExC_state,INSUBP,parno);
11533                     goto insert_if_check_paren;
11534                 }
11535                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11536                     /* (?(1)...) */
11537                     char c;
11538                     UV uv;
11539                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11540                         && uv <= I32_MAX
11541                     ) {
11542                         parno = (I32)uv;
11543                         RExC_parse = (char*)endptr;
11544                     }
11545                     else {
11546                         vFAIL("panic: grok_atoUV returned FALSE");
11547                     }
11548                     ret = reganode(pRExC_state, GROUPP, parno);
11549
11550                  insert_if_check_paren:
11551                     if (UCHARAT(RExC_parse) != ')') {
11552                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11553                         vFAIL("Switch condition not recognized");
11554                     }
11555                     nextchar(pRExC_state);
11556                   insert_if:
11557                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11558                     br = regbranch(pRExC_state, &flags, 1,depth+1);
11559                     if (br == NULL) {
11560                         RETURN_NULL_ON_RESTART(flags,flagp);
11561                         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11562                               (UV) flags);
11563                     } else
11564                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11565                                                           LONGJMP, 0));
11566                     c = UCHARAT(RExC_parse);
11567                     nextchar(pRExC_state);
11568                     if (flags&HASWIDTH)
11569                         *flagp |= HASWIDTH;
11570                     if (c == '|') {
11571                         if (is_define)
11572                             vFAIL("(?(DEFINE)....) does not allow branches");
11573
11574                         /* Fake one for optimizer.  */
11575                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11576
11577                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
11578                             RETURN_NULL_ON_RESTART(flags,flagp);
11579                             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11580                                   (UV) flags);
11581                         }
11582                         REGTAIL(pRExC_state, ret, lastbr);
11583                         if (flags&HASWIDTH)
11584                             *flagp |= HASWIDTH;
11585                         c = UCHARAT(RExC_parse);
11586                         nextchar(pRExC_state);
11587                     }
11588                     else
11589                         lastbr = NULL;
11590                     if (c != ')') {
11591                         if (RExC_parse >= RExC_end)
11592                             vFAIL("Switch (?(condition)... not terminated");
11593                         else
11594                             vFAIL("Switch (?(condition)... contains too many branches");
11595                     }
11596                     ender = reg_node(pRExC_state, TAIL);
11597                     REGTAIL(pRExC_state, br, ender);
11598                     if (lastbr) {
11599                         REGTAIL(pRExC_state, lastbr, ender);
11600                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11601                     }
11602                     else
11603                         REGTAIL(pRExC_state, ret, ender);
11604                     RExC_size++; /* XXX WHY do we need this?!!
11605                                     For large programs it seems to be required
11606                                     but I can't figure out why. -- dmq*/
11607                     return ret;
11608                 }
11609                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11610                 vFAIL("Unknown switch condition (?(...))");
11611             }
11612             case '[':           /* (?[ ... ]) */
11613                 return handle_regex_sets(pRExC_state, NULL, flagp, depth+1,
11614                                          oregcomp_parse);
11615             case 0: /* A NUL */
11616                 RExC_parse--; /* for vFAIL to print correctly */
11617                 vFAIL("Sequence (? incomplete");
11618                 break;
11619             default: /* e.g., (?i) */
11620                 RExC_parse = (char *) seqstart + 1;
11621               parse_flags:
11622                 parse_lparen_question_flags(pRExC_state);
11623                 if (UCHARAT(RExC_parse) != ':') {
11624                     if (RExC_parse < RExC_end)
11625                         nextchar(pRExC_state);
11626                     *flagp = TRYAGAIN;
11627                     return NULL;
11628                 }
11629                 paren = ':';
11630                 nextchar(pRExC_state);
11631                 ret = NULL;
11632                 goto parse_rest;
11633             } /* end switch */
11634         }
11635         else {
11636             if (*RExC_parse == '{' && PASS2) {
11637                 ckWARNregdep(RExC_parse + 1,
11638                             "Unescaped left brace in regex is "
11639                             "deprecated here (and will be fatal "
11640                             "in Perl 5.32), passed through");
11641             }
11642             /* Not bothering to indent here, as the above 'else' is temporary
11643              * */
11644         if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11645           capturing_parens:
11646             parno = RExC_npar;
11647             RExC_npar++;
11648
11649             ret = reganode(pRExC_state, OPEN, parno);
11650             if (!SIZE_ONLY ){
11651                 if (!RExC_nestroot)
11652                     RExC_nestroot = parno;
11653                 if (RExC_open_parens && !RExC_open_parens[parno])
11654                 {
11655                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11656                         "%*s%*s Setting open paren #%" IVdf " to %d\n",
11657                         22, "|    |", (int)(depth * 2 + 1), "",
11658                         (IV)parno, REG_NODE_NUM(ret)));
11659                     RExC_open_parens[parno]= ret;
11660                 }
11661             }
11662             Set_Node_Length(ret, 1); /* MJD */
11663             Set_Node_Offset(ret, RExC_parse); /* MJD */
11664             is_open = 1;
11665         } else {
11666             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11667             paren = ':';
11668             ret = NULL;
11669         }
11670         }
11671     }
11672     else                        /* ! paren */
11673         ret = NULL;
11674
11675    parse_rest:
11676     /* Pick up the branches, linking them together. */
11677     parse_start = RExC_parse;   /* MJD */
11678     br = regbranch(pRExC_state, &flags, 1,depth+1);
11679
11680     /*     branch_len = (paren != 0); */
11681
11682     if (br == NULL) {
11683         RETURN_NULL_ON_RESTART(flags,flagp);
11684         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11685     }
11686     if (*RExC_parse == '|') {
11687         if (!SIZE_ONLY && RExC_extralen) {
11688             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11689         }
11690         else {                  /* MJD */
11691             reginsert(pRExC_state, BRANCH, br, depth+1);
11692             Set_Node_Length(br, paren != 0);
11693             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11694         }
11695         have_branch = 1;
11696         if (SIZE_ONLY)
11697             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11698     }
11699     else if (paren == ':') {
11700         *flagp |= flags&SIMPLE;
11701     }
11702     if (is_open) {                              /* Starts with OPEN. */
11703         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11704     }
11705     else if (paren != '?')              /* Not Conditional */
11706         ret = br;
11707     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11708     lastbr = br;
11709     while (*RExC_parse == '|') {
11710         if (!SIZE_ONLY && RExC_extralen) {
11711             ender = reganode(pRExC_state, LONGJMP,0);
11712
11713             /* Append to the previous. */
11714             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11715         }
11716         if (SIZE_ONLY)
11717             RExC_extralen += 2;         /* Account for LONGJMP. */
11718         nextchar(pRExC_state);
11719         if (freeze_paren) {
11720             if (RExC_npar > after_freeze)
11721                 after_freeze = RExC_npar;
11722             RExC_npar = freeze_paren;
11723         }
11724         br = regbranch(pRExC_state, &flags, 0, depth+1);
11725
11726         if (br == NULL) {
11727             RETURN_NULL_ON_RESTART(flags,flagp);
11728             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11729         }
11730         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11731         lastbr = br;
11732         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11733     }
11734
11735     if (have_branch || paren != ':') {
11736         /* Make a closing node, and hook it on the end. */
11737         switch (paren) {
11738         case ':':
11739             ender = reg_node(pRExC_state, TAIL);
11740             break;
11741         case 1: case 2:
11742             ender = reganode(pRExC_state, CLOSE, parno);
11743             if ( RExC_close_parens ) {
11744                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11745                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
11746                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11747                 RExC_close_parens[parno]= ender;
11748                 if (RExC_nestroot == parno)
11749                     RExC_nestroot = 0;
11750             }
11751             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11752             Set_Node_Length(ender,1); /* MJD */
11753             break;
11754         case 's':
11755             ender = reg_node(pRExC_state, SRCLOSE);
11756             RExC_in_script_run = 0;
11757             break;
11758         case '<':
11759         case 'a':
11760         case 'A':
11761         case 'b':
11762         case 'B':
11763         case ',':
11764         case '=':
11765         case '!':
11766             *flagp &= ~HASWIDTH;
11767             /* FALLTHROUGH */
11768         case 't':   /* aTomic */
11769         case '>':
11770             ender = reg_node(pRExC_state, SUCCEED);
11771             break;
11772         case 0:
11773             ender = reg_node(pRExC_state, END);
11774             if (!SIZE_ONLY) {
11775                 assert(!RExC_end_op); /* there can only be one! */
11776                 RExC_end_op = ender;
11777                 if (RExC_close_parens) {
11778                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11779                         "%*s%*s Setting close paren #0 (END) to %d\n",
11780                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11781
11782                     RExC_close_parens[0]= ender;
11783                 }
11784             }
11785             break;
11786         }
11787         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11788             DEBUG_PARSE_MSG("lsbr");
11789             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11790             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11791             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11792                           SvPV_nolen_const(RExC_mysv1),
11793                           (IV)REG_NODE_NUM(lastbr),
11794                           SvPV_nolen_const(RExC_mysv2),
11795                           (IV)REG_NODE_NUM(ender),
11796                           (IV)(ender - lastbr)
11797             );
11798         });
11799         REGTAIL(pRExC_state, lastbr, ender);
11800
11801         if (have_branch && !SIZE_ONLY) {
11802             char is_nothing= 1;
11803             if (depth==1)
11804                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11805
11806             /* Hook the tails of the branches to the closing node. */
11807             for (br = ret; br; br = regnext(br)) {
11808                 const U8 op = PL_regkind[OP(br)];
11809                 if (op == BRANCH) {
11810                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11811                     if ( OP(NEXTOPER(br)) != NOTHING
11812                          || regnext(NEXTOPER(br)) != ender)
11813                         is_nothing= 0;
11814                 }
11815                 else if (op == BRANCHJ) {
11816                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11817                     /* for now we always disable this optimisation * /
11818                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11819                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11820                     */
11821                         is_nothing= 0;
11822                 }
11823             }
11824             if (is_nothing) {
11825                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11826                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11827                     DEBUG_PARSE_MSG("NADA");
11828                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11829                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11830                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11831                                   SvPV_nolen_const(RExC_mysv1),
11832                                   (IV)REG_NODE_NUM(ret),
11833                                   SvPV_nolen_const(RExC_mysv2),
11834                                   (IV)REG_NODE_NUM(ender),
11835                                   (IV)(ender - ret)
11836                     );
11837                 });
11838                 OP(br)= NOTHING;
11839                 if (OP(ender) == TAIL) {
11840                     NEXT_OFF(br)= 0;
11841                     RExC_emit= br + 1;
11842                 } else {
11843                     regnode *opt;
11844                     for ( opt= br + 1; opt < ender ; opt++ )
11845                         OP(opt)= OPTIMIZED;
11846                     NEXT_OFF(br)= ender - br;
11847                 }
11848             }
11849         }
11850     }
11851
11852     {
11853         const char *p;
11854          /* Even/odd or x=don't care: 010101x10x */
11855         static const char parens[] = "=!aA<,>Bbt";
11856          /* flag below is set to 0 up through 'A'; 1 for larger */
11857
11858         if (paren && (p = strchr(parens, paren))) {
11859             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11860             int flag = (p - parens) > 3;
11861
11862             if (paren == '>' || paren == 't') {
11863                 node = SUSPEND, flag = 0;
11864             }
11865
11866             reginsert(pRExC_state, node,ret, depth+1);
11867             Set_Node_Cur_Length(ret, parse_start);
11868             Set_Node_Offset(ret, parse_start + 1);
11869             ret->flags = flag;
11870             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11871         }
11872     }
11873
11874     /* Check for proper termination. */
11875     if (paren) {
11876         /* restore original flags, but keep (?p) and, if we've changed from /d
11877          * rules to /u, keep the /u */
11878         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11879         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11880             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11881         }
11882         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11883             RExC_parse = oregcomp_parse;
11884             vFAIL("Unmatched (");
11885         }
11886         nextchar(pRExC_state);
11887     }
11888     else if (!paren && RExC_parse < RExC_end) {
11889         if (*RExC_parse == ')') {
11890             RExC_parse++;
11891             vFAIL("Unmatched )");
11892         }
11893         else
11894             FAIL("Junk on end of regexp");      /* "Can't happen". */
11895         NOT_REACHED; /* NOTREACHED */
11896     }
11897
11898     if (RExC_in_lookbehind) {
11899         RExC_in_lookbehind--;
11900     }
11901     if (after_freeze > RExC_npar)
11902         RExC_npar = after_freeze;
11903     return(ret);
11904 }
11905
11906 /*
11907  - regbranch - one alternative of an | operator
11908  *
11909  * Implements the concatenation operator.
11910  *
11911  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11912  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11913  */
11914 STATIC regnode *
11915 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11916 {
11917     regnode *ret;
11918     regnode *chain = NULL;
11919     regnode *latest;
11920     I32 flags = 0, c = 0;
11921     GET_RE_DEBUG_FLAGS_DECL;
11922
11923     PERL_ARGS_ASSERT_REGBRANCH;
11924
11925     DEBUG_PARSE("brnc");
11926
11927     if (first)
11928         ret = NULL;
11929     else {
11930         if (!SIZE_ONLY && RExC_extralen)
11931             ret = reganode(pRExC_state, BRANCHJ,0);
11932         else {
11933             ret = reg_node(pRExC_state, BRANCH);
11934             Set_Node_Length(ret, 1);
11935         }
11936     }
11937
11938     if (!first && SIZE_ONLY)
11939         RExC_extralen += 1;                     /* BRANCHJ */
11940
11941     *flagp = WORST;                     /* Tentatively. */
11942
11943     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11944                             FALSE /* Don't force to /x */ );
11945     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11946         flags &= ~TRYAGAIN;
11947         latest = regpiece(pRExC_state, &flags,depth+1);
11948         if (latest == NULL) {
11949             if (flags & TRYAGAIN)
11950                 continue;
11951             RETURN_NULL_ON_RESTART(flags,flagp);
11952             FAIL2("panic: regpiece returned NULL, flags=%#" UVxf, (UV) flags);
11953         }
11954         else if (ret == NULL)
11955             ret = latest;
11956         *flagp |= flags&(HASWIDTH|POSTPONED);
11957         if (chain == NULL)      /* First piece. */
11958             *flagp |= flags&SPSTART;
11959         else {
11960             /* FIXME adding one for every branch after the first is probably
11961              * excessive now we have TRIE support. (hv) */
11962             MARK_NAUGHTY(1);
11963             REGTAIL(pRExC_state, chain, latest);
11964         }
11965         chain = latest;
11966         c++;
11967     }
11968     if (chain == NULL) {        /* Loop ran zero times. */
11969         chain = reg_node(pRExC_state, NOTHING);
11970         if (ret == NULL)
11971             ret = chain;
11972     }
11973     if (c == 1) {
11974         *flagp |= flags&SIMPLE;
11975     }
11976
11977     return ret;
11978 }
11979
11980 /*
11981  - regpiece - something followed by possible quantifier * + ? {n,m}
11982  *
11983  * Note that the branching code sequences used for ? and the general cases
11984  * of * and + are somewhat optimized:  they use the same NOTHING node as
11985  * both the endmarker for their branch list and the body of the last branch.
11986  * It might seem that this node could be dispensed with entirely, but the
11987  * endmarker role is not redundant.
11988  *
11989  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11990  * TRYAGAIN.
11991  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11992  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11993  */
11994 STATIC regnode *
11995 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11996 {
11997     regnode *ret;
11998     char op;
11999     char *next;
12000     I32 flags;
12001     const char * const origparse = RExC_parse;
12002     I32 min;
12003     I32 max = REG_INFTY;
12004 #ifdef RE_TRACK_PATTERN_OFFSETS
12005     char *parse_start;
12006 #endif
12007     const char *maxpos = NULL;
12008     UV uv;
12009
12010     /* Save the original in case we change the emitted regop to a FAIL. */
12011     regnode * const orig_emit = RExC_emit;
12012
12013     GET_RE_DEBUG_FLAGS_DECL;
12014
12015     PERL_ARGS_ASSERT_REGPIECE;
12016
12017     DEBUG_PARSE("piec");
12018
12019     ret = regatom(pRExC_state, &flags,depth+1);
12020     if (ret == NULL) {
12021         RETURN_NULL_ON_RESTART_OR_FLAGS(flags,flagp,TRYAGAIN);
12022         FAIL2("panic: regatom returned NULL, flags=%#" UVxf, (UV) flags);
12023     }
12024
12025     op = *RExC_parse;
12026
12027     if (op == '{' && regcurly(RExC_parse)) {
12028         maxpos = NULL;
12029 #ifdef RE_TRACK_PATTERN_OFFSETS
12030         parse_start = RExC_parse; /* MJD */
12031 #endif
12032         next = RExC_parse + 1;
12033         while (isDIGIT(*next) || *next == ',') {
12034             if (*next == ',') {
12035                 if (maxpos)
12036                     break;
12037                 else
12038                     maxpos = next;
12039             }
12040             next++;
12041         }
12042         if (*next == '}') {             /* got one */
12043             const char* endptr;
12044             if (!maxpos)
12045                 maxpos = next;
12046             RExC_parse++;
12047             if (isDIGIT(*RExC_parse)) {
12048                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
12049                     vFAIL("Invalid quantifier in {,}");
12050                 if (uv >= REG_INFTY)
12051                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12052                 min = (I32)uv;
12053             } else {
12054                 min = 0;
12055             }
12056             if (*maxpos == ',')
12057                 maxpos++;
12058             else
12059                 maxpos = RExC_parse;
12060             if (isDIGIT(*maxpos)) {
12061                 if (!grok_atoUV(maxpos, &uv, &endptr))
12062                     vFAIL("Invalid quantifier in {,}");
12063                 if (uv >= REG_INFTY)
12064                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12065                 max = (I32)uv;
12066             } else {
12067                 max = REG_INFTY;                /* meaning "infinity" */
12068             }
12069             RExC_parse = next;
12070             nextchar(pRExC_state);
12071             if (max < min) {    /* If can't match, warn and optimize to fail
12072                                    unconditionally */
12073                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
12074                 if (PASS2) {
12075                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
12076                     NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
12077                 }
12078                 return ret;
12079             }
12080             else if (min == max && *RExC_parse == '?')
12081             {
12082                 if (PASS2) {
12083                     ckWARN2reg(RExC_parse + 1,
12084                                "Useless use of greediness modifier '%c'",
12085                                *RExC_parse);
12086                 }
12087             }
12088
12089           do_curly:
12090             if ((flags&SIMPLE)) {
12091                 if (min == 0 && max == REG_INFTY) {
12092                     reginsert(pRExC_state, STAR, ret, depth+1);
12093                     MARK_NAUGHTY(4);
12094                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12095                     goto nest_check;
12096                 }
12097                 if (min == 1 && max == REG_INFTY) {
12098                     reginsert(pRExC_state, PLUS, ret, depth+1);
12099                     MARK_NAUGHTY(3);
12100                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12101                     goto nest_check;
12102                 }
12103                 MARK_NAUGHTY_EXP(2, 2);
12104                 reginsert(pRExC_state, CURLY, ret, depth+1);
12105                 Set_Node_Offset(ret, parse_start+1); /* MJD */
12106                 Set_Node_Cur_Length(ret, parse_start);
12107             }
12108             else {
12109                 regnode * const w = reg_node(pRExC_state, WHILEM);
12110
12111                 w->flags = 0;
12112                 REGTAIL(pRExC_state, ret, w);
12113                 if (!SIZE_ONLY && RExC_extralen) {
12114                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
12115                     reginsert(pRExC_state, NOTHING,ret, depth+1);
12116                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
12117                 }
12118                 reginsert(pRExC_state, CURLYX,ret, depth+1);
12119                                 /* MJD hk */
12120                 Set_Node_Offset(ret, parse_start+1);
12121                 Set_Node_Length(ret,
12122                                 op == '{' ? (RExC_parse - parse_start) : 1);
12123
12124                 if (!SIZE_ONLY && RExC_extralen)
12125                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
12126                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
12127                 if (SIZE_ONLY)
12128                     RExC_whilem_seen++, RExC_extralen += 3;
12129                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
12130             }
12131             ret->flags = 0;
12132
12133             if (min > 0)
12134                 *flagp = WORST;
12135             if (max > 0)
12136                 *flagp |= HASWIDTH;
12137             if (!SIZE_ONLY) {
12138                 ARG1_SET(ret, (U16)min);
12139                 ARG2_SET(ret, (U16)max);
12140             }
12141             if (max == REG_INFTY)
12142                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12143
12144             goto nest_check;
12145         }
12146     }
12147
12148     if (!ISMULT1(op)) {
12149         *flagp = flags;
12150         return(ret);
12151     }
12152
12153 #if 0                           /* Now runtime fix should be reliable. */
12154
12155     /* if this is reinstated, don't forget to put this back into perldiag:
12156
12157             =item Regexp *+ operand could be empty at {#} in regex m/%s/
12158
12159            (F) The part of the regexp subject to either the * or + quantifier
12160            could match an empty string. The {#} shows in the regular
12161            expression about where the problem was discovered.
12162
12163     */
12164
12165     if (!(flags&HASWIDTH) && op != '?')
12166       vFAIL("Regexp *+ operand could be empty");
12167 #endif
12168
12169 #ifdef RE_TRACK_PATTERN_OFFSETS
12170     parse_start = RExC_parse;
12171 #endif
12172     nextchar(pRExC_state);
12173
12174     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
12175
12176     if (op == '*') {
12177         min = 0;
12178         goto do_curly;
12179     }
12180     else if (op == '+') {
12181         min = 1;
12182         goto do_curly;
12183     }
12184     else if (op == '?') {
12185         min = 0; max = 1;
12186         goto do_curly;
12187     }
12188   nest_check:
12189     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
12190         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
12191         ckWARN2reg(RExC_parse,
12192                    "%" UTF8f " matches null string many times",
12193                    UTF8fARG(UTF, (RExC_parse >= origparse
12194                                  ? RExC_parse - origparse
12195                                  : 0),
12196                    origparse));
12197         (void)ReREFCNT_inc(RExC_rx_sv);
12198     }
12199
12200     if (*RExC_parse == '?') {
12201         nextchar(pRExC_state);
12202         reginsert(pRExC_state, MINMOD, ret, depth+1);
12203         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
12204     }
12205     else if (*RExC_parse == '+') {
12206         regnode *ender;
12207         nextchar(pRExC_state);
12208         ender = reg_node(pRExC_state, SUCCEED);
12209         REGTAIL(pRExC_state, ret, ender);
12210         reginsert(pRExC_state, SUSPEND, ret, depth+1);
12211         ender = reg_node(pRExC_state, TAIL);
12212         REGTAIL(pRExC_state, ret, ender);
12213     }
12214
12215     if (ISMULT2(RExC_parse)) {
12216         RExC_parse++;
12217         vFAIL("Nested quantifiers");
12218     }
12219
12220     return(ret);
12221 }
12222
12223 STATIC bool
12224 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
12225                 regnode ** node_p,
12226                 UV * code_point_p,
12227                 int * cp_count,
12228                 I32 * flagp,
12229                 const bool strict,
12230                 const U32 depth
12231     )
12232 {
12233  /* This routine teases apart the various meanings of \N and returns
12234   * accordingly.  The input parameters constrain which meaning(s) is/are valid
12235   * in the current context.
12236   *
12237   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
12238   *
12239   * If <code_point_p> is not NULL, the context is expecting the result to be a
12240   * single code point.  If this \N instance turns out to a single code point,
12241   * the function returns TRUE and sets *code_point_p to that code point.
12242   *
12243   * If <node_p> is not NULL, the context is expecting the result to be one of
12244   * the things representable by a regnode.  If this \N instance turns out to be
12245   * one such, the function generates the regnode, returns TRUE and sets *node_p
12246   * to point to that regnode.
12247   *
12248   * If this instance of \N isn't legal in any context, this function will
12249   * generate a fatal error and not return.
12250   *
12251   * On input, RExC_parse should point to the first char following the \N at the
12252   * time of the call.  On successful return, RExC_parse will have been updated
12253   * to point to just after the sequence identified by this routine.  Also
12254   * *flagp has been updated as needed.
12255   *
12256   * When there is some problem with the current context and this \N instance,
12257   * the function returns FALSE, without advancing RExC_parse, nor setting
12258   * *node_p, nor *code_point_p, nor *flagp.
12259   *
12260   * If <cp_count> is not NULL, the caller wants to know the length (in code
12261   * points) that this \N sequence matches.  This is set even if the function
12262   * returns FALSE, as detailed below.
12263   *
12264   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
12265   *
12266   * Probably the most common case is for the \N to specify a single code point.
12267   * *cp_count will be set to 1, and *code_point_p will be set to that code
12268   * point.
12269   *
12270   * Another possibility is for the input to be an empty \N{}, which for
12271   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
12272   * will be set to a generated NOTHING node.
12273   *
12274   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
12275   * set to 0. *node_p will be set to a generated REG_ANY node.
12276   *
12277   * The fourth possibility is that \N resolves to a sequence of more than one
12278   * code points.  *cp_count will be set to the number of code points in the
12279   * sequence. *node_p * will be set to a generated node returned by this
12280   * function calling S_reg().
12281   *
12282   * The final possibility is that it is premature to be calling this function;
12283   * that pass1 needs to be restarted.  This can happen when this changes from
12284   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
12285   * latter occurs only when the fourth possibility would otherwise be in
12286   * effect, and is because one of those code points requires the pattern to be
12287   * recompiled as UTF-8.  The function returns FALSE, and sets the
12288   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
12289   * happens, the caller needs to desist from continuing parsing, and return
12290   * this information to its caller.  This is not set for when there is only one
12291   * code point, as this can be called as part of an ANYOF node, and they can
12292   * store above-Latin1 code points without the pattern having to be in UTF-8.
12293   *
12294   * For non-single-quoted regexes, the tokenizer has resolved character and
12295   * sequence names inside \N{...} into their Unicode values, normalizing the
12296   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
12297   * hex-represented code points in the sequence.  This is done there because
12298   * the names can vary based on what charnames pragma is in scope at the time,
12299   * so we need a way to take a snapshot of what they resolve to at the time of
12300   * the original parse. [perl #56444].
12301   *
12302   * That parsing is skipped for single-quoted regexes, so we may here get
12303   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
12304   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
12305   * is legal and handled here.  The code point is Unicode, and has to be
12306   * translated into the native character set for non-ASCII platforms.
12307   */
12308
12309     char * endbrace;    /* points to '}' following the name */
12310     char * endchar;     /* Points to '.' or '}' ending cur char in the input
12311                            stream */
12312     char* p = RExC_parse; /* Temporary */
12313
12314     SV * substitute_parse;
12315     STRLEN len;
12316     char *orig_end;
12317     char *save_start;
12318     I32 flags;
12319
12320     GET_RE_DEBUG_FLAGS_DECL;
12321
12322     PERL_ARGS_ASSERT_GROK_BSLASH_N;
12323
12324     GET_RE_DEBUG_FLAGS;
12325
12326     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
12327     assert(! (node_p && cp_count));               /* At most 1 should be set */
12328
12329     if (cp_count) {     /* Initialize return for the most common case */
12330         *cp_count = 1;
12331     }
12332
12333     /* The [^\n] meaning of \N ignores spaces and comments under the /x
12334      * modifier.  The other meanings do not, so use a temporary until we find
12335      * out which we are being called with */
12336     skip_to_be_ignored_text(pRExC_state, &p,
12337                             FALSE /* Don't force to /x */ );
12338
12339     /* Disambiguate between \N meaning a named character versus \N meaning
12340      * [^\n].  The latter is assumed when the {...} following the \N is a legal
12341      * quantifier, or there is no '{' at all */
12342     if (*p != '{' || regcurly(p)) {
12343         RExC_parse = p;
12344         if (cp_count) {
12345             *cp_count = -1;
12346         }
12347
12348         if (! node_p) {
12349             return FALSE;
12350         }
12351
12352         *node_p = reg_node(pRExC_state, REG_ANY);
12353         *flagp |= HASWIDTH|SIMPLE;
12354         MARK_NAUGHTY(1);
12355         Set_Node_Length(*node_p, 1); /* MJD */
12356         return TRUE;
12357     }
12358
12359     /* The test above made sure that the next real character is a '{', but
12360      * under the /x modifier, it could be separated by space (or a comment and
12361      * \n) and this is not allowed (for consistency with \x{...} and the
12362      * tokenizer handling of \N{NAME}). */
12363     if (*RExC_parse != '{') {
12364         vFAIL("Missing braces on \\N{}");
12365     }
12366
12367     RExC_parse++;       /* Skip past the '{' */
12368
12369     endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
12370     if (! endbrace) { /* no trailing brace */
12371         vFAIL2("Missing right brace on \\%c{}", 'N');
12372     }
12373
12374     /* Here, we have decided it should be a named character or sequence */
12375     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
12376                                         semantics */
12377
12378     if (endbrace == RExC_parse) {   /* empty: \N{} */
12379         if (strict) {
12380             RExC_parse++;   /* Position after the "}" */
12381             vFAIL("Zero length \\N{}");
12382         }
12383         if (cp_count) {
12384             *cp_count = 0;
12385         }
12386         nextchar(pRExC_state);
12387         if (! node_p) {
12388             return FALSE;
12389         }
12390
12391         *node_p = reg_node(pRExC_state,NOTHING);
12392         return TRUE;
12393     }
12394
12395     /* If we haven't got something that begins with 'U+', then it didn't get lexed. */
12396     if (   endbrace - RExC_parse < 2
12397         || strnNE(RExC_parse, "U+", 2))
12398     {
12399         RExC_parse = endbrace;  /* position msg's '<--HERE' */
12400         vFAIL("\\N{NAME} must be resolved by the lexer");
12401     }
12402
12403         RExC_parse += 2;    /* Skip past the 'U+' */
12404
12405         /* Because toke.c has generated a special construct for us guaranteed
12406          * not to have NULs, we can use a str function */
12407         endchar = RExC_parse + strcspn(RExC_parse, ".}");
12408
12409         /* Code points are separated by dots.  If none, there is only one code
12410          * point, and is terminated by the brace */
12411
12412         if (endchar >= endbrace) {
12413             STRLEN length_of_hex;
12414             I32 grok_hex_flags;
12415
12416             /* Here, exactly one code point.  If that isn't what is wanted,
12417              * fail */
12418             if (! code_point_p) {
12419                 RExC_parse = p;
12420                 return FALSE;
12421             }
12422
12423             /* Convert code point from hex */
12424             length_of_hex = (STRLEN)(endchar - RExC_parse);
12425             grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
12426                             | PERL_SCAN_DISALLOW_PREFIX
12427
12428                                 /* No errors in the first pass (See [perl
12429                                 * #122671].)  We let the code below find the
12430                                 * errors when there are multiple chars. */
12431                             | ((SIZE_ONLY)
12432                                 ? PERL_SCAN_SILENT_ILLDIGIT
12433                                 : 0);
12434
12435             /* This routine is the one place where both single- and
12436              * double-quotish \N{U+xxxx} are evaluated.  The value is a Unicode
12437              * code point which must be converted to native. */
12438             *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
12439                                             &length_of_hex,
12440                                             &grok_hex_flags,
12441                                             NULL));
12442
12443             /* The tokenizer should have guaranteed validity, but it's possible
12444              * to bypass it by using single quoting, so check.  Don't do the
12445              * check here when there are multiple chars; we do it below anyway.
12446              * */
12447             if (length_of_hex == 0
12448                 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
12449             {
12450                 RExC_parse += length_of_hex;    /* Includes all the valid */
12451                 RExC_parse += (RExC_orig_utf8)  /* point to after 1st invalid */
12452                                 ? UTF8SKIP(RExC_parse)
12453                                 : 1;
12454                 /* Guard against malformed utf8 */
12455                 if (RExC_parse >= endchar) {
12456                     RExC_parse = endchar;
12457                 }
12458                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
12459             }
12460
12461             RExC_parse = endbrace + 1;
12462             return TRUE;
12463         }
12464
12465         /* Here, is a multiple character sequence */
12466
12467         /* Count the code points, if desired, in the sequence */
12468         if (cp_count) {
12469             *cp_count = 0;
12470             while (RExC_parse < endbrace) {
12471                 /* Point to the beginning of the next character in the sequence. */
12472                 RExC_parse = endchar + 1;
12473                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
12474                 (*cp_count)++;
12475             }
12476         }
12477
12478         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12479          * But don't backup up the pointer if the caller wants to know how many
12480          * code points there are (they can then handle things) */
12481         if (! node_p) {
12482             if (! cp_count) {
12483                 RExC_parse = p;
12484             }
12485             return FALSE;
12486         }
12487
12488         /* What is done here is to convert this to a sub-pattern of the form
12489          * \x{char1}\x{char2}...  and then call reg recursively to parse it
12490          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
12491          * while not having to worry about special handling that some code
12492          * points may have. */
12493
12494         substitute_parse = newSVpvs("?:");
12495
12496         while (RExC_parse < endbrace) {
12497
12498             /* Convert to notation the rest of the code understands */
12499             sv_catpv(substitute_parse, "\\x{");
12500             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
12501             sv_catpv(substitute_parse, "}");
12502
12503             /* Point to the beginning of the next character in the sequence. */
12504             RExC_parse = endchar + 1;
12505             endchar = RExC_parse + strcspn(RExC_parse, ".}");
12506
12507         }
12508         sv_catpv(substitute_parse, ")");
12509
12510         len = SvCUR(substitute_parse);
12511
12512         /* Don't allow empty number */
12513         if (len < (STRLEN) 8) {
12514             RExC_parse = endbrace;
12515             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12516         }
12517
12518         /* The values are Unicode, and therefore not subject to recoding, but
12519          * have to be converted to native on a non-Unicode (meaning non-ASCII)
12520          * platform. */
12521 #ifdef EBCDIC
12522         RExC_recode_x_to_native = 1;
12523 #endif
12524
12525     save_start = RExC_start;
12526     orig_end = RExC_end;
12527
12528     RExC_parse = RExC_start = RExC_adjusted_start = SvPV(substitute_parse,
12529                                                          len);
12530     RExC_end = RExC_parse + len;
12531
12532     *node_p = reg(pRExC_state, 1, &flags, depth+1);
12533
12534     /* Restore the saved values */
12535     RExC_start = RExC_adjusted_start = save_start;
12536     RExC_parse = endbrace;
12537     RExC_end = orig_end;
12538 #ifdef EBCDIC
12539     RExC_recode_x_to_native = 0;
12540 #endif
12541
12542     SvREFCNT_dec_NN(substitute_parse);
12543
12544     if (! *node_p) {
12545         RETURN_X_ON_RESTART(FALSE, flags,flagp);
12546         FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#" UVxf,
12547             (UV) flags);
12548     }
12549     *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12550
12551     nextchar(pRExC_state);
12552
12553     return TRUE;
12554 }
12555
12556
12557 PERL_STATIC_INLINE U8
12558 S_compute_EXACTish(RExC_state_t *pRExC_state)
12559 {
12560     U8 op;
12561
12562     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12563
12564     if (! FOLD) {
12565         return (LOC)
12566                 ? EXACTL
12567                 : EXACT;
12568     }
12569
12570     op = get_regex_charset(RExC_flags);
12571     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12572         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12573                  been, so there is no hole */
12574     }
12575
12576     return op + EXACTF;
12577 }
12578
12579 PERL_STATIC_INLINE void
12580 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12581                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12582                          bool downgradable)
12583 {
12584     /* This knows the details about sizing an EXACTish node, setting flags for
12585      * it (by setting <*flagp>, and potentially populating it with a single
12586      * character.
12587      *
12588      * If <len> (the length in bytes) is non-zero, this function assumes that
12589      * the node has already been populated, and just does the sizing.  In this
12590      * case <code_point> should be the final code point that has already been
12591      * placed into the node.  This value will be ignored except that under some
12592      * circumstances <*flagp> is set based on it.
12593      *
12594      * If <len> is zero, the function assumes that the node is to contain only
12595      * the single character given by <code_point> and calculates what <len>
12596      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12597      * additionally will populate the node's STRING with <code_point> or its
12598      * fold if folding.
12599      *
12600      * In both cases <*flagp> is appropriately set
12601      *
12602      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12603      * 255, must be folded (the former only when the rules indicate it can
12604      * match 'ss')
12605      *
12606      * When it does the populating, it looks at the flag 'downgradable'.  If
12607      * true with a node that folds, it checks if the single code point
12608      * participates in a fold, and if not downgrades the node to an EXACT.
12609      * This helps the optimizer */
12610
12611     bool len_passed_in = cBOOL(len != 0);
12612     U8 character[UTF8_MAXBYTES_CASE+1];
12613
12614     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12615
12616     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12617      * sizing difference, and is extra work that is thrown away */
12618     if (downgradable && ! PASS2) {
12619         downgradable = FALSE;
12620     }
12621
12622     if (! len_passed_in) {
12623         if (UTF) {
12624             if (UVCHR_IS_INVARIANT(code_point)) {
12625                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12626                     *character = (U8) code_point;
12627                 }
12628                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12629                           ASCII, which isn't the same thing as INVARIANT on
12630                           EBCDIC, but it works there, as the extra invariants
12631                           fold to themselves) */
12632                     *character = toFOLD((U8) code_point);
12633
12634                     /* We can downgrade to an EXACT node if this character
12635                      * isn't a folding one.  Note that this assumes that
12636                      * nothing above Latin1 folds to some other invariant than
12637                      * one of these alphabetics; otherwise we would also have
12638                      * to check:
12639                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12640                      *      || ASCII_FOLD_RESTRICTED))
12641                      */
12642                     if (downgradable && PL_fold[code_point] == code_point) {
12643                         OP(node) = EXACT;
12644                     }
12645                 }
12646                 len = 1;
12647             }
12648             else if (FOLD && (! LOC
12649                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12650             {   /* Folding, and ok to do so now */
12651                 UV folded = _to_uni_fold_flags(
12652                                    code_point,
12653                                    character,
12654                                    &len,
12655                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12656                                                       ? FOLD_FLAGS_NOMIX_ASCII
12657                                                       : 0));
12658                 if (downgradable
12659                     && folded == code_point /* This quickly rules out many
12660                                                cases, avoiding the
12661                                                _invlist_contains_cp() overhead
12662                                                for those.  */
12663                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12664                 {
12665                     OP(node) = (LOC)
12666                                ? EXACTL
12667                                : EXACT;
12668                 }
12669             }
12670             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12671
12672                 /* Not folding this cp, and can output it directly */
12673                 *character = UTF8_TWO_BYTE_HI(code_point);
12674                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12675                 len = 2;
12676             }
12677             else {
12678                 uvchr_to_utf8( character, code_point);
12679                 len = UTF8SKIP(character);
12680             }
12681         } /* Else pattern isn't UTF8.  */
12682         else if (! FOLD) {
12683             *character = (U8) code_point;
12684             len = 1;
12685         } /* Else is folded non-UTF8 */
12686 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12687    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12688                                       || UNICODE_DOT_DOT_VERSION > 0)
12689         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12690 #else
12691         else if (1) {
12692 #endif
12693             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12694              * comments at join_exact()); */
12695             *character = (U8) code_point;
12696             len = 1;
12697
12698             /* Can turn into an EXACT node if we know the fold at compile time,
12699              * and it folds to itself and doesn't particpate in other folds */
12700             if (downgradable
12701                 && ! LOC
12702                 && PL_fold_latin1[code_point] == code_point
12703                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12704                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12705             {
12706                 OP(node) = EXACT;
12707             }
12708         } /* else is Sharp s.  May need to fold it */
12709         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12710             *character = 's';
12711             *(character + 1) = 's';
12712             len = 2;
12713         }
12714         else {
12715             *character = LATIN_SMALL_LETTER_SHARP_S;
12716             len = 1;
12717         }
12718     }
12719
12720     if (SIZE_ONLY) {
12721         RExC_size += STR_SZ(len);
12722     }
12723     else {
12724         RExC_emit += STR_SZ(len);
12725         STR_LEN(node) = len;
12726         if (! len_passed_in) {
12727             Copy((char *) character, STRING(node), len, char);
12728         }
12729     }
12730
12731     *flagp |= HASWIDTH;
12732
12733     /* A single character node is SIMPLE, except for the special-cased SHARP S
12734      * under /di. */
12735     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12736 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12737    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12738                                       || UNICODE_DOT_DOT_VERSION > 0)
12739         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12740             || ! FOLD || ! DEPENDS_SEMANTICS)
12741 #endif
12742     ) {
12743         *flagp |= SIMPLE;
12744     }
12745
12746     /* The OP may not be well defined in PASS1 */
12747     if (PASS2 && OP(node) == EXACTFL) {
12748         RExC_contains_locale = 1;
12749     }
12750 }
12751
12752 STATIC bool
12753 S_new_regcurly(const char *s, const char *e)
12754 {
12755     /* This is a temporary function designed to match the most lenient form of
12756      * a {m,n} quantifier we ever envision, with either number omitted, and
12757      * spaces anywhere between/before/after them.
12758      *
12759      * If this function fails, then the string it matches is very unlikely to
12760      * ever be considered a valid quantifier, so we can allow the '{' that
12761      * begins it to be considered as a literal */
12762
12763     bool has_min = FALSE;
12764     bool has_max = FALSE;
12765
12766     PERL_ARGS_ASSERT_NEW_REGCURLY;
12767
12768     if (s >= e || *s++ != '{')
12769         return FALSE;
12770
12771     while (s < e && isSPACE(*s)) {
12772         s++;
12773     }
12774     while (s < e && isDIGIT(*s)) {
12775         has_min = TRUE;
12776         s++;
12777     }
12778     while (s < e && isSPACE(*s)) {
12779         s++;
12780     }
12781
12782     if (*s == ',') {
12783         s++;
12784         while (s < e && isSPACE(*s)) {
12785             s++;
12786         }
12787         while (s < e && isDIGIT(*s)) {
12788             has_max = TRUE;
12789             s++;
12790         }
12791         while (s < e && isSPACE(*s)) {
12792             s++;
12793         }
12794     }
12795
12796     return s < e && *s == '}' && (has_min || has_max);
12797 }
12798
12799 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12800  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12801
12802 static I32
12803 S_backref_value(char *p)
12804 {
12805     const char* endptr;
12806     UV val;
12807     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12808         return (I32)val;
12809     return I32_MAX;
12810 }
12811
12812
12813 /*
12814  - regatom - the lowest level
12815
12816    Try to identify anything special at the start of the current parse position.
12817    If there is, then handle it as required. This may involve generating a
12818    single regop, such as for an assertion; or it may involve recursing, such as
12819    to handle a () structure.
12820
12821    If the string doesn't start with something special then we gobble up
12822    as much literal text as we can.  If we encounter a quantifier, we have to
12823    back off the final literal character, as that quantifier applies to just it
12824    and not to the whole string of literals.
12825
12826    Once we have been able to handle whatever type of thing started the
12827    sequence, we return.
12828
12829    Note: we have to be careful with escapes, as they can be both literal
12830    and special, and in the case of \10 and friends, context determines which.
12831
12832    A summary of the code structure is:
12833
12834    switch (first_byte) {
12835         cases for each special:
12836             handle this special;
12837             break;
12838         case '\\':
12839             switch (2nd byte) {
12840                 cases for each unambiguous special:
12841                     handle this special;
12842                     break;
12843                 cases for each ambigous special/literal:
12844                     disambiguate;
12845                     if (special)  handle here
12846                     else goto defchar;
12847                 default: // unambiguously literal:
12848                     goto defchar;
12849             }
12850         default:  // is a literal char
12851             // FALL THROUGH
12852         defchar:
12853             create EXACTish node for literal;
12854             while (more input and node isn't full) {
12855                 switch (input_byte) {
12856                    cases for each special;
12857                        make sure parse pointer is set so that the next call to
12858                            regatom will see this special first
12859                        goto loopdone; // EXACTish node terminated by prev. char
12860                    default:
12861                        append char to EXACTISH node;
12862                 }
12863                 get next input byte;
12864             }
12865         loopdone:
12866    }
12867    return the generated node;
12868
12869    Specifically there are two separate switches for handling
12870    escape sequences, with the one for handling literal escapes requiring
12871    a dummy entry for all of the special escapes that are actually handled
12872    by the other.
12873
12874    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12875    TRYAGAIN.
12876    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12877    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12878    Otherwise does not return NULL.
12879 */
12880
12881 STATIC regnode *
12882 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12883 {
12884     regnode *ret = NULL;
12885     I32 flags = 0;
12886     char *parse_start;
12887     U8 op;
12888     int invert = 0;
12889     U8 arg;
12890
12891     GET_RE_DEBUG_FLAGS_DECL;
12892
12893     *flagp = WORST;             /* Tentatively. */
12894
12895     DEBUG_PARSE("atom");
12896
12897     PERL_ARGS_ASSERT_REGATOM;
12898
12899   tryagain:
12900     parse_start = RExC_parse;
12901     assert(RExC_parse < RExC_end);
12902     switch ((U8)*RExC_parse) {
12903     case '^':
12904         RExC_seen_zerolen++;
12905         nextchar(pRExC_state);
12906         if (RExC_flags & RXf_PMf_MULTILINE)
12907             ret = reg_node(pRExC_state, MBOL);
12908         else
12909             ret = reg_node(pRExC_state, SBOL);
12910         Set_Node_Length(ret, 1); /* MJD */
12911         break;
12912     case '$':
12913         nextchar(pRExC_state);
12914         if (*RExC_parse)
12915             RExC_seen_zerolen++;
12916         if (RExC_flags & RXf_PMf_MULTILINE)
12917             ret = reg_node(pRExC_state, MEOL);
12918         else
12919             ret = reg_node(pRExC_state, SEOL);
12920         Set_Node_Length(ret, 1); /* MJD */
12921         break;
12922     case '.':
12923         nextchar(pRExC_state);
12924         if (RExC_flags & RXf_PMf_SINGLELINE)
12925             ret = reg_node(pRExC_state, SANY);
12926         else
12927             ret = reg_node(pRExC_state, REG_ANY);
12928         *flagp |= HASWIDTH|SIMPLE;
12929         MARK_NAUGHTY(1);
12930         Set_Node_Length(ret, 1); /* MJD */
12931         break;
12932     case '[':
12933     {
12934         char * const oregcomp_parse = ++RExC_parse;
12935         ret = regclass(pRExC_state, flagp,depth+1,
12936                        FALSE, /* means parse the whole char class */
12937                        TRUE, /* allow multi-char folds */
12938                        FALSE, /* don't silence non-portable warnings. */
12939                        (bool) RExC_strict,
12940                        TRUE, /* Allow an optimized regnode result */
12941                        NULL,
12942                        NULL);
12943         if (ret == NULL) {
12944             RETURN_NULL_ON_RESTART_FLAGP_OR_FLAGS(flagp,NEED_UTF8);
12945             FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12946                   (UV) *flagp);
12947         }
12948         if (*RExC_parse != ']') {
12949             RExC_parse = oregcomp_parse;
12950             vFAIL("Unmatched [");
12951         }
12952         nextchar(pRExC_state);
12953         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12954         break;
12955     }
12956     case '(':
12957         nextchar(pRExC_state);
12958         ret = reg(pRExC_state, 2, &flags,depth+1);
12959         if (ret == NULL) {
12960                 if (flags & TRYAGAIN) {
12961                     if (RExC_parse >= RExC_end) {
12962                          /* Make parent create an empty node if needed. */
12963                         *flagp |= TRYAGAIN;
12964                         return(NULL);
12965                     }
12966                     goto tryagain;
12967                 }
12968                 RETURN_NULL_ON_RESTART(flags,flagp);
12969                 FAIL2("panic: reg returned NULL to regatom, flags=%#" UVxf,
12970                                                                  (UV) flags);
12971         }
12972         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12973         break;
12974     case '|':
12975     case ')':
12976         if (flags & TRYAGAIN) {
12977             *flagp |= TRYAGAIN;
12978             return NULL;
12979         }
12980         vFAIL("Internal urp");
12981                                 /* Supposed to be caught earlier. */
12982         break;
12983     case '?':
12984     case '+':
12985     case '*':
12986         RExC_parse++;
12987         vFAIL("Quantifier follows nothing");
12988         break;
12989     case '\\':
12990         /* Special Escapes
12991
12992            This switch handles escape sequences that resolve to some kind
12993            of special regop and not to literal text. Escape sequnces that
12994            resolve to literal text are handled below in the switch marked
12995            "Literal Escapes".
12996
12997            Every entry in this switch *must* have a corresponding entry
12998            in the literal escape switch. However, the opposite is not
12999            required, as the default for this switch is to jump to the
13000            literal text handling code.
13001         */
13002         RExC_parse++;
13003         switch ((U8)*RExC_parse) {
13004         /* Special Escapes */
13005         case 'A':
13006             RExC_seen_zerolen++;
13007             ret = reg_node(pRExC_state, SBOL);
13008             /* SBOL is shared with /^/ so we set the flags so we can tell
13009              * /\A/ from /^/ in split. We check ret because first pass we
13010              * have no regop struct to set the flags on. */
13011             if (PASS2)
13012                 ret->flags = 1;
13013             *flagp |= SIMPLE;
13014             goto finish_meta_pat;
13015         case 'G':
13016             ret = reg_node(pRExC_state, GPOS);
13017             RExC_seen |= REG_GPOS_SEEN;
13018             *flagp |= SIMPLE;
13019             goto finish_meta_pat;
13020         case 'K':
13021             RExC_seen_zerolen++;
13022             ret = reg_node(pRExC_state, KEEPS);
13023             *flagp |= SIMPLE;
13024             /* XXX:dmq : disabling in-place substitution seems to
13025              * be necessary here to avoid cases of memory corruption, as
13026              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
13027              */
13028             RExC_seen |= REG_LOOKBEHIND_SEEN;
13029             goto finish_meta_pat;
13030         case 'Z':
13031             ret = reg_node(pRExC_state, SEOL);
13032             *flagp |= SIMPLE;
13033             RExC_seen_zerolen++;                /* Do not optimize RE away */
13034             goto finish_meta_pat;
13035         case 'z':
13036             ret = reg_node(pRExC_state, EOS);
13037             *flagp |= SIMPLE;
13038             RExC_seen_zerolen++;                /* Do not optimize RE away */
13039             goto finish_meta_pat;
13040         case 'C':
13041             vFAIL("\\C no longer supported");
13042         case 'X':
13043             ret = reg_node(pRExC_state, CLUMP);
13044             *flagp |= HASWIDTH;
13045             goto finish_meta_pat;
13046
13047         case 'W':
13048             invert = 1;
13049             /* FALLTHROUGH */
13050         case 'w':
13051             arg = ANYOF_WORDCHAR;
13052             goto join_posix;
13053
13054         case 'B':
13055             invert = 1;
13056             /* FALLTHROUGH */
13057         case 'b':
13058           {
13059             regex_charset charset = get_regex_charset(RExC_flags);
13060
13061             RExC_seen_zerolen++;
13062             RExC_seen |= REG_LOOKBEHIND_SEEN;
13063             op = BOUND + charset;
13064
13065             if (op == BOUNDL) {
13066                 RExC_contains_locale = 1;
13067             }
13068
13069             ret = reg_node(pRExC_state, op);
13070             *flagp |= SIMPLE;
13071             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
13072                 FLAGS(ret) = TRADITIONAL_BOUND;
13073                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
13074                     OP(ret) = BOUNDA;
13075                 }
13076             }
13077             else {
13078                 STRLEN length;
13079                 char name = *RExC_parse;
13080                 char * endbrace = NULL;
13081                 RExC_parse += 2;
13082                 if (RExC_parse < RExC_end) {
13083                     endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
13084                 }
13085
13086                 if (! endbrace) {
13087                     vFAIL2("Missing right brace on \\%c{}", name);
13088                 }
13089                 /* XXX Need to decide whether to take spaces or not.  Should be
13090                  * consistent with \p{}, but that currently is SPACE, which
13091                  * means vertical too, which seems wrong
13092                  * while (isBLANK(*RExC_parse)) {
13093                     RExC_parse++;
13094                 }*/
13095                 if (endbrace == RExC_parse) {
13096                     RExC_parse++;  /* After the '}' */
13097                     vFAIL2("Empty \\%c{}", name);
13098                 }
13099                 length = endbrace - RExC_parse;
13100                 /*while (isBLANK(*(RExC_parse + length - 1))) {
13101                     length--;
13102                 }*/
13103                 switch (*RExC_parse) {
13104                     case 'g':
13105                         if (    length != 1
13106                             && (memNEs(RExC_parse + 1, length - 1, "cb")))
13107                         {
13108                             goto bad_bound_type;
13109                         }
13110                         FLAGS(ret) = GCB_BOUND;
13111                         break;
13112                     case 'l':
13113                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13114                             goto bad_bound_type;
13115                         }
13116                         FLAGS(ret) = LB_BOUND;
13117                         break;
13118                     case 's':
13119                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13120                             goto bad_bound_type;
13121                         }
13122                         FLAGS(ret) = SB_BOUND;
13123                         break;
13124                     case 'w':
13125                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13126                             goto bad_bound_type;
13127                         }
13128                         FLAGS(ret) = WB_BOUND;
13129                         break;
13130                     default:
13131                       bad_bound_type:
13132                         RExC_parse = endbrace;
13133                         vFAIL2utf8f(
13134                             "'%" UTF8f "' is an unknown bound type",
13135                             UTF8fARG(UTF, length, endbrace - length));
13136                         NOT_REACHED; /*NOTREACHED*/
13137                 }
13138                 RExC_parse = endbrace;
13139                 REQUIRE_UNI_RULES(flagp, NULL);
13140
13141                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
13142                     OP(ret) = BOUNDU;
13143                     length += 4;
13144
13145                     /* Don't have to worry about UTF-8, in this message because
13146                      * to get here the contents of the \b must be ASCII */
13147                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
13148                               "Using /u for '%.*s' instead of /%s",
13149                               (unsigned) length,
13150                               endbrace - length + 1,
13151                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
13152                               ? ASCII_RESTRICT_PAT_MODS
13153                               : ASCII_MORE_RESTRICT_PAT_MODS);
13154                 }
13155             }
13156
13157             if (PASS2 && invert) {
13158                 OP(ret) += NBOUND - BOUND;
13159             }
13160             goto finish_meta_pat;
13161           }
13162
13163         case 'D':
13164             invert = 1;
13165             /* FALLTHROUGH */
13166         case 'd':
13167             arg = ANYOF_DIGIT;
13168             if (! DEPENDS_SEMANTICS) {
13169                 goto join_posix;
13170             }
13171
13172             /* \d doesn't have any matches in the upper Latin1 range, hence /d
13173              * is equivalent to /u.  Changing to /u saves some branches at
13174              * runtime */
13175             op = POSIXU;
13176             goto join_posix_op_known;
13177
13178         case 'R':
13179             ret = reg_node(pRExC_state, LNBREAK);
13180             *flagp |= HASWIDTH|SIMPLE;
13181             goto finish_meta_pat;
13182
13183         case 'H':
13184             invert = 1;
13185             /* FALLTHROUGH */
13186         case 'h':
13187             arg = ANYOF_BLANK;
13188             op = POSIXU;
13189             goto join_posix_op_known;
13190
13191         case 'V':
13192             invert = 1;
13193             /* FALLTHROUGH */
13194         case 'v':
13195             arg = ANYOF_VERTWS;
13196             op = POSIXU;
13197             goto join_posix_op_known;
13198
13199         case 'S':
13200             invert = 1;
13201             /* FALLTHROUGH */
13202         case 's':
13203             arg = ANYOF_SPACE;
13204
13205           join_posix:
13206
13207             op = POSIXD + get_regex_charset(RExC_flags);
13208             if (op > POSIXA) {  /* /aa is same as /a */
13209                 op = POSIXA;
13210             }
13211             else if (op == POSIXL) {
13212                 RExC_contains_locale = 1;
13213             }
13214
13215           join_posix_op_known:
13216
13217             if (invert) {
13218                 op += NPOSIXD - POSIXD;
13219             }
13220
13221             ret = reg_node(pRExC_state, op);
13222             if (! SIZE_ONLY) {
13223                 FLAGS(ret) = namedclass_to_classnum(arg);
13224             }
13225
13226             *flagp |= HASWIDTH|SIMPLE;
13227             /* FALLTHROUGH */
13228
13229           finish_meta_pat:
13230             if (   UCHARAT(RExC_parse + 1) == '{'
13231                 && UNLIKELY(! new_regcurly(RExC_parse + 1, RExC_end)))
13232             {
13233                 RExC_parse += 2;
13234                 vFAIL("Unescaped left brace in regex is illegal here");
13235             }
13236             nextchar(pRExC_state);
13237             Set_Node_Length(ret, 2); /* MJD */
13238             break;
13239         case 'p':
13240         case 'P':
13241             RExC_parse--;
13242
13243             ret = regclass(pRExC_state, flagp,depth+1,
13244                            TRUE, /* means just parse this element */
13245                            FALSE, /* don't allow multi-char folds */
13246                            FALSE, /* don't silence non-portable warnings.  It
13247                                      would be a bug if these returned
13248                                      non-portables */
13249                            (bool) RExC_strict,
13250                            TRUE, /* Allow an optimized regnode result */
13251                            NULL,
13252                            NULL);
13253             RETURN_NULL_ON_RESTART_FLAGP(flagp);
13254             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
13255              * multi-char folds are allowed.  */
13256             if (!ret)
13257                 FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
13258                       (UV) *flagp);
13259
13260             RExC_parse--;
13261
13262             Set_Node_Offset(ret, parse_start);
13263             Set_Node_Cur_Length(ret, parse_start - 2);
13264             nextchar(pRExC_state);
13265             break;
13266         case 'N':
13267             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
13268              * \N{...} evaluates to a sequence of more than one code points).
13269              * The function call below returns a regnode, which is our result.
13270              * The parameters cause it to fail if the \N{} evaluates to a
13271              * single code point; we handle those like any other literal.  The
13272              * reason that the multicharacter case is handled here and not as
13273              * part of the EXACtish code is because of quantifiers.  In
13274              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
13275              * this way makes that Just Happen. dmq.
13276              * join_exact() will join this up with adjacent EXACTish nodes
13277              * later on, if appropriate. */
13278             ++RExC_parse;
13279             if (grok_bslash_N(pRExC_state,
13280                               &ret,     /* Want a regnode returned */
13281                               NULL,     /* Fail if evaluates to a single code
13282                                            point */
13283                               NULL,     /* Don't need a count of how many code
13284                                            points */
13285                               flagp,
13286                               RExC_strict,
13287                               depth)
13288             ) {
13289                 break;
13290             }
13291
13292             RETURN_NULL_ON_RESTART_FLAGP(flagp);
13293
13294             /* Here, evaluates to a single code point.  Go get that */
13295             RExC_parse = parse_start;
13296             goto defchar;
13297
13298         case 'k':    /* Handle \k<NAME> and \k'NAME' */
13299       parse_named_seq:
13300         {
13301             char ch;
13302             if (   RExC_parse >= RExC_end - 1
13303                 || ((   ch = RExC_parse[1]) != '<'
13304                                       && ch != '\''
13305                                       && ch != '{'))
13306             {
13307                 RExC_parse++;
13308                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
13309                 vFAIL2("Sequence %.2s... not terminated",parse_start);
13310             } else {
13311                 RExC_parse += 2;
13312                 ret = handle_named_backref(pRExC_state,
13313                                            flagp,
13314                                            parse_start,
13315                                            (ch == '<')
13316                                            ? '>'
13317                                            : (ch == '{')
13318                                              ? '}'
13319                                              : '\'');
13320             }
13321             break;
13322         }
13323         case 'g':
13324         case '1': case '2': case '3': case '4':
13325         case '5': case '6': case '7': case '8': case '9':
13326             {
13327                 I32 num;
13328                 bool hasbrace = 0;
13329
13330                 if (*RExC_parse == 'g') {
13331                     bool isrel = 0;
13332
13333                     RExC_parse++;
13334                     if (*RExC_parse == '{') {
13335                         RExC_parse++;
13336                         hasbrace = 1;
13337                     }
13338                     if (*RExC_parse == '-') {
13339                         RExC_parse++;
13340                         isrel = 1;
13341                     }
13342                     if (hasbrace && !isDIGIT(*RExC_parse)) {
13343                         if (isrel) RExC_parse--;
13344                         RExC_parse -= 2;
13345                         goto parse_named_seq;
13346                     }
13347
13348                     if (RExC_parse >= RExC_end) {
13349                         goto unterminated_g;
13350                     }
13351                     num = S_backref_value(RExC_parse);
13352                     if (num == 0)
13353                         vFAIL("Reference to invalid group 0");
13354                     else if (num == I32_MAX) {
13355                          if (isDIGIT(*RExC_parse))
13356                             vFAIL("Reference to nonexistent group");
13357                         else
13358                           unterminated_g:
13359                             vFAIL("Unterminated \\g... pattern");
13360                     }
13361
13362                     if (isrel) {
13363                         num = RExC_npar - num;
13364                         if (num < 1)
13365                             vFAIL("Reference to nonexistent or unclosed group");
13366                     }
13367                 }
13368                 else {
13369                     num = S_backref_value(RExC_parse);
13370                     /* bare \NNN might be backref or octal - if it is larger
13371                      * than or equal RExC_npar then it is assumed to be an
13372                      * octal escape. Note RExC_npar is +1 from the actual
13373                      * number of parens. */
13374                     /* Note we do NOT check if num == I32_MAX here, as that is
13375                      * handled by the RExC_npar check */
13376
13377                     if (
13378                         /* any numeric escape < 10 is always a backref */
13379                         num > 9
13380                         /* any numeric escape < RExC_npar is a backref */
13381                         && num >= RExC_npar
13382                         /* cannot be an octal escape if it starts with 8 */
13383                         && *RExC_parse != '8'
13384                         /* cannot be an octal escape it it starts with 9 */
13385                         && *RExC_parse != '9'
13386                     )
13387                     {
13388                         /* Probably not a backref, instead likely to be an
13389                          * octal character escape, e.g. \35 or \777.
13390                          * The above logic should make it obvious why using
13391                          * octal escapes in patterns is problematic. - Yves */
13392                         RExC_parse = parse_start;
13393                         goto defchar;
13394                     }
13395                 }
13396
13397                 /* At this point RExC_parse points at a numeric escape like
13398                  * \12 or \88 or something similar, which we should NOT treat
13399                  * as an octal escape. It may or may not be a valid backref
13400                  * escape. For instance \88888888 is unlikely to be a valid
13401                  * backref. */
13402                 while (isDIGIT(*RExC_parse))
13403                     RExC_parse++;
13404                 if (hasbrace) {
13405                     if (*RExC_parse != '}')
13406                         vFAIL("Unterminated \\g{...} pattern");
13407                     RExC_parse++;
13408                 }
13409                 if (!SIZE_ONLY) {
13410                     if (num > (I32)RExC_rx->nparens)
13411                         vFAIL("Reference to nonexistent group");
13412                 }
13413                 RExC_sawback = 1;
13414                 ret = reganode(pRExC_state,
13415                                ((! FOLD)
13416                                  ? REF
13417                                  : (ASCII_FOLD_RESTRICTED)
13418                                    ? REFFA
13419                                    : (AT_LEAST_UNI_SEMANTICS)
13420                                      ? REFFU
13421                                      : (LOC)
13422                                        ? REFFL
13423                                        : REFF),
13424                                 num);
13425                 *flagp |= HASWIDTH;
13426
13427                 /* override incorrect value set in reganode MJD */
13428                 Set_Node_Offset(ret, parse_start);
13429                 Set_Node_Cur_Length(ret, parse_start-1);
13430                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13431                                         FALSE /* Don't force to /x */ );
13432             }
13433             break;
13434         case '\0':
13435             if (RExC_parse >= RExC_end)
13436                 FAIL("Trailing \\");
13437             /* FALLTHROUGH */
13438         default:
13439             /* Do not generate "unrecognized" warnings here, we fall
13440                back into the quick-grab loop below */
13441             RExC_parse = parse_start;
13442             goto defchar;
13443         } /* end of switch on a \foo sequence */
13444         break;
13445
13446     case '#':
13447
13448         /* '#' comments should have been spaced over before this function was
13449          * called */
13450         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13451         /*
13452         if (RExC_flags & RXf_PMf_EXTENDED) {
13453             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13454             if (RExC_parse < RExC_end)
13455                 goto tryagain;
13456         }
13457         */
13458
13459         /* FALLTHROUGH */
13460
13461     default:
13462           defchar: {
13463
13464             /* Here, we have determined that the next thing is probably a
13465              * literal character.  RExC_parse points to the first byte of its
13466              * definition.  (It still may be an escape sequence that evaluates
13467              * to a single character) */
13468
13469             STRLEN len = 0;
13470             UV ender = 0;
13471             char *p;
13472             char *s;
13473
13474 /* This allows us to fill a node with just enough spare so that if the final
13475  * character folds, its expansion is guaranteed to fit */
13476 #define MAX_NODE_STRING_SIZE (255-UTF8_MAXBYTES_CASE)
13477             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE+1];
13478
13479             char *s0;
13480             U8 upper_parse = MAX_NODE_STRING_SIZE;
13481
13482             /* We start out as an EXACT node, even if under /i, until we find a
13483              * character which is in a fold.  The algorithm now segregates into
13484              * separate nodes, characters that fold from those that don't under
13485              * /i.  (This hopefull will create nodes that are fixed strings
13486              * even under /i, giving the optimizer something to grab onto to.)
13487              * So, if a node has something in it and the next character is in
13488              * the opposite category, that node is closed up, and the function
13489              * returns.  Then regatom is called again, and a new node is
13490              * created for the new category. */
13491             U8 node_type = EXACT;
13492
13493             bool next_is_quantifier;
13494             char * oldp = NULL;
13495
13496             /* We can convert EXACTF nodes to EXACTFU if they contain only
13497              * characters that match identically regardless of the target
13498              * string's UTF8ness.  The reason to do this is that EXACTF is not
13499              * trie-able, EXACTFU is.
13500              *
13501              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13502              * contain only above-Latin1 characters (hence must be in UTF8),
13503              * which don't participate in folds with Latin1-range characters,
13504              * as the latter's folds aren't known until runtime.  (We don't
13505              * need to figure this out until pass 2) */
13506             bool maybe_exactfu = PASS2;
13507
13508             /* The node_type may change below, but since the size of the node
13509              * doesn't change, it works */
13510             ret = reg_node(pRExC_state, node_type);
13511
13512             /* In pass1, folded, we use a temporary buffer instead of the
13513              * actual node, as the node doesn't exist yet */
13514             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
13515
13516             s0 = s;
13517
13518           reparse:
13519
13520             /* This breaks under rare circumstances.  If folding, we do not
13521              * want to split a node at a character that is a non-final in a
13522              * multi-char fold, as an input string could just happen to want to
13523              * match across the node boundary.  The code at the end of the loop
13524              * looks for this, and backs off until it finds not such a
13525              * character, but it is possible (though extremely, extremely
13526              * unlikely) for all characters in the node to be non-final fold
13527              * ones, in which case we just leave the node fully filled, and
13528              * hope that it doesn't match the string in just the wrong place */
13529
13530             assert( ! UTF     /* Is at the beginning of a character */
13531                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13532                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13533
13534             /* Here, we have a literal character.  Find the maximal string of
13535              * them in the input that we can fit into a single EXACTish node.
13536              * We quit at the first non-literal or when the node gets full, or
13537              * under /i the categorization of folding/non-folding character
13538              * changes */
13539             for (p = RExC_parse; len < upper_parse && p < RExC_end; ) {
13540
13541                 /* In most cases each iteration adds one byte to the output.
13542                  * The exceptions override this */
13543                 Size_t added_len = 1;
13544
13545                 oldp = p;
13546
13547                 /* White space has already been ignored */
13548                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13549                        || ! is_PATWS_safe((p), RExC_end, UTF));
13550
13551                 switch ((U8)*p) {
13552                 case '^':
13553                 case '$':
13554                 case '.':
13555                 case '[':
13556                 case '(':
13557                 case ')':
13558                 case '|':
13559                     goto loopdone;
13560                 case '\\':
13561                     /* Literal Escapes Switch
13562
13563                        This switch is meant to handle escape sequences that
13564                        resolve to a literal character.
13565
13566                        Every escape sequence that represents something
13567                        else, like an assertion or a char class, is handled
13568                        in the switch marked 'Special Escapes' above in this
13569                        routine, but also has an entry here as anything that
13570                        isn't explicitly mentioned here will be treated as
13571                        an unescaped equivalent literal.
13572                     */
13573
13574                     switch ((U8)*++p) {
13575                     /* These are all the special escapes. */
13576                     case 'A':             /* Start assertion */
13577                     case 'b': case 'B':   /* Word-boundary assertion*/
13578                     case 'C':             /* Single char !DANGEROUS! */
13579                     case 'd': case 'D':   /* digit class */
13580                     case 'g': case 'G':   /* generic-backref, pos assertion */
13581                     case 'h': case 'H':   /* HORIZWS */
13582                     case 'k': case 'K':   /* named backref, keep marker */
13583                     case 'p': case 'P':   /* Unicode property */
13584                               case 'R':   /* LNBREAK */
13585                     case 's': case 'S':   /* space class */
13586                     case 'v': case 'V':   /* VERTWS */
13587                     case 'w': case 'W':   /* word class */
13588                     case 'X':             /* eXtended Unicode "combining
13589                                              character sequence" */
13590                     case 'z': case 'Z':   /* End of line/string assertion */
13591                         --p;
13592                         goto loopdone;
13593
13594                     /* Anything after here is an escape that resolves to a
13595                        literal. (Except digits, which may or may not)
13596                      */
13597                     case 'n':
13598                         ender = '\n';
13599                         p++;
13600                         break;
13601                     case 'N': /* Handle a single-code point named character. */
13602                         RExC_parse = p + 1;
13603                         if (! grok_bslash_N(pRExC_state,
13604                                             NULL,   /* Fail if evaluates to
13605                                                        anything other than a
13606                                                        single code point */
13607                                             &ender, /* The returned single code
13608                                                        point */
13609                                             NULL,   /* Don't need a count of
13610                                                        how many code points */
13611                                             flagp,
13612                                             RExC_strict,
13613                                             depth)
13614                         ) {
13615                             if (*flagp & NEED_UTF8)
13616                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13617                             RETURN_NULL_ON_RESTART_FLAGP(flagp);
13618
13619                             /* Here, it wasn't a single code point.  Go close
13620                              * up this EXACTish node.  The switch() prior to
13621                              * this switch handles the other cases */
13622                             RExC_parse = p = oldp;
13623                             goto loopdone;
13624                         }
13625                         p = RExC_parse;
13626                         RExC_parse = parse_start;
13627                         if (ender > 0xff) {
13628                             REQUIRE_UTF8(flagp);
13629                         }
13630                         break;
13631                     case 'r':
13632                         ender = '\r';
13633                         p++;
13634                         break;
13635                     case 't':
13636                         ender = '\t';
13637                         p++;
13638                         break;
13639                     case 'f':
13640                         ender = '\f';
13641                         p++;
13642                         break;
13643                     case 'e':
13644                         ender = ESC_NATIVE;
13645                         p++;
13646                         break;
13647                     case 'a':
13648                         ender = '\a';
13649                         p++;
13650                         break;
13651                     case 'o':
13652                         {
13653                             UV result;
13654                             const char* error_msg;
13655
13656                             bool valid = grok_bslash_o(&p,
13657                                                        RExC_end,
13658                                                        &result,
13659                                                        &error_msg,
13660                                                        PASS2, /* out warnings */
13661                                                        (bool) RExC_strict,
13662                                                        TRUE, /* Output warnings
13663                                                                 for non-
13664                                                                 portables */
13665                                                        UTF);
13666                             if (! valid) {
13667                                 RExC_parse = p; /* going to die anyway; point
13668                                                    to exact spot of failure */
13669                                 vFAIL(error_msg);
13670                             }
13671                             ender = result;
13672                             if (ender > 0xff) {
13673                                 REQUIRE_UTF8(flagp);
13674                             }
13675                             break;
13676                         }
13677                     case 'x':
13678                         {
13679                             UV result = UV_MAX; /* initialize to erroneous
13680                                                    value */
13681                             const char* error_msg;
13682
13683                             bool valid = grok_bslash_x(&p,
13684                                                        RExC_end,
13685                                                        &result,
13686                                                        &error_msg,
13687                                                        PASS2, /* out warnings */
13688                                                        (bool) RExC_strict,
13689                                                        TRUE, /* Silence warnings
13690                                                                 for non-
13691                                                                 portables */
13692                                                        UTF);
13693                             if (! valid) {
13694                                 RExC_parse = p; /* going to die anyway; point
13695                                                    to exact spot of failure */
13696                                 vFAIL(error_msg);
13697                             }
13698                             ender = result;
13699
13700                             if (ender < 0x100) {
13701 #ifdef EBCDIC
13702                                 if (RExC_recode_x_to_native) {
13703                                     ender = LATIN1_TO_NATIVE(ender);
13704                                 }
13705 #endif
13706                             }
13707                             else {
13708                                 REQUIRE_UTF8(flagp);
13709                             }
13710                             break;
13711                         }
13712                     case 'c':
13713                         p++;
13714                         ender = grok_bslash_c(*p++, PASS2);
13715                         break;
13716                     case '8': case '9': /* must be a backreference */
13717                         --p;
13718                         /* we have an escape like \8 which cannot be an octal escape
13719                          * so we exit the loop, and let the outer loop handle this
13720                          * escape which may or may not be a legitimate backref. */
13721                         goto loopdone;
13722                     case '1': case '2': case '3':case '4':
13723                     case '5': case '6': case '7':
13724                         /* When we parse backslash escapes there is ambiguity
13725                          * between backreferences and octal escapes. Any escape
13726                          * from \1 - \9 is a backreference, any multi-digit
13727                          * escape which does not start with 0 and which when
13728                          * evaluated as decimal could refer to an already
13729                          * parsed capture buffer is a back reference. Anything
13730                          * else is octal.
13731                          *
13732                          * Note this implies that \118 could be interpreted as
13733                          * 118 OR as "\11" . "8" depending on whether there
13734                          * were 118 capture buffers defined already in the
13735                          * pattern.  */
13736
13737                         /* NOTE, RExC_npar is 1 more than the actual number of
13738                          * parens we have seen so far, hence the < RExC_npar below. */
13739
13740                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13741                         {  /* Not to be treated as an octal constant, go
13742                                    find backref */
13743                             --p;
13744                             goto loopdone;
13745                         }
13746                         /* FALLTHROUGH */
13747                     case '0':
13748                         {
13749                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13750                             STRLEN numlen = 3;
13751                             ender = grok_oct(p, &numlen, &flags, NULL);
13752                             if (ender > 0xff) {
13753                                 REQUIRE_UTF8(flagp);
13754                             }
13755                             p += numlen;
13756                             if (PASS2   /* like \08, \178 */
13757                                 && numlen < 3
13758                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13759                             {
13760                                 reg_warn_non_literal_string(
13761                                          p + 1,
13762                                          form_short_octal_warning(p, numlen));
13763                             }
13764                         }
13765                         break;
13766                     case '\0':
13767                         if (p >= RExC_end)
13768                             FAIL("Trailing \\");
13769                         /* FALLTHROUGH */
13770                     default:
13771                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13772                             /* Include any left brace following the alpha to emphasize
13773                              * that it could be part of an escape at some point
13774                              * in the future */
13775                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13776                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13777                         }
13778                         goto normal_default;
13779                     } /* End of switch on '\' */
13780                     break;
13781                 case '{':
13782                     /* Currently we allow an lbrace at the start of a construct
13783                      * without raising a warning.  This is because we think we
13784                      * will never want such a brace to be meant to be other
13785                      * than taken literally. */
13786                     if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
13787
13788                         /* But, we raise a fatal warning otherwise, as the
13789                          * deprecation cycle has come and gone.  Except that it
13790                          * turns out that some heavily-relied on upstream
13791                          * software, notably GNU Autoconf, have failed to fix
13792                          * their uses.  For these, don't make it fatal unless
13793                          * we anticipate using the '{' for something else.
13794                          * This happens after any alpha, and for a looser {m,n}
13795                          * quantifier specification */
13796                         if (      RExC_strict
13797                             || (  p > parse_start + 1
13798                                 && isALPHA_A(*(p - 1))
13799                                 && *(p - 2) == '\\')
13800                             || new_regcurly(p, RExC_end))
13801                         {
13802                             RExC_parse = p + 1;
13803                             vFAIL("Unescaped left brace in regex is "
13804                                   "illegal here");
13805                         }
13806                         if (PASS2) {
13807                             ckWARNregdep(p + 1,
13808                                         "Unescaped left brace in regex is "
13809                                         "deprecated here (and will be fatal "
13810                                         "in Perl 5.30), passed through");
13811                         }
13812                     }
13813                     goto normal_default;
13814                 case '}':
13815                 case ']':
13816                     if (PASS2 && p > RExC_parse && RExC_strict) {
13817                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
13818                     }
13819                     /*FALLTHROUGH*/
13820                 default:    /* A literal character */
13821                   normal_default:
13822                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13823                         STRLEN numlen;
13824                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13825                                                &numlen, UTF8_ALLOW_DEFAULT);
13826                         p += numlen;
13827                     }
13828                     else
13829                         ender = (U8) *p++;
13830                     break;
13831                 } /* End of switch on the literal */
13832
13833                 /* Here, have looked at the literal character, and <ender>
13834                  * contains its ordinal; <p> points to the character after it.
13835                  * We need to check if the next non-ignored thing is a
13836                  * quantifier.  Move <p> to after anything that should be
13837                  * ignored, which, as a side effect, positions <p> for the next
13838                  * loop iteration */
13839                 skip_to_be_ignored_text(pRExC_state, &p,
13840                                         FALSE /* Don't force to /x */ );
13841
13842                 /* If the next thing is a quantifier, it applies to this
13843                  * character only, which means that this character has to be in
13844                  * its own node and can't just be appended to the string in an
13845                  * existing node, so if there are already other characters in
13846                  * the node, close the node with just them, and set up to do
13847                  * this character again next time through, when it will be the
13848                  * only thing in its new node */
13849
13850                 next_is_quantifier =    LIKELY(p < RExC_end)
13851                                      && UNLIKELY(ISMULT2(p));
13852
13853                 if (next_is_quantifier && LIKELY(len)) {
13854                     p = oldp;
13855                     goto loopdone;
13856                 }
13857
13858                 /* Ready to add 'ender' to the node */
13859
13860                 if (! FOLD) {  /* The simple case, just append the literal */
13861
13862                     /* In the sizing pass, we need only the size of the
13863                      * character we are appending, hence we can delay getting
13864                      * its representation until PASS2. */
13865                     if (SIZE_ONLY) {
13866                         if (UTF && ! UVCHR_IS_INVARIANT(ender)) {
13867                             const STRLEN unilen = UVCHR_SKIP(ender);
13868                             s += unilen;
13869                             added_len = unilen;
13870                         }
13871                         else {
13872                             s++;
13873                         }
13874                     } else { /* PASS2 */
13875                       not_fold_common:
13876                         if (UTF && ! UVCHR_IS_INVARIANT(ender)) {
13877                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13878                             added_len = (char *) new_s - s;
13879                             s = (char *) new_s;
13880                         }
13881                         else {
13882                             *(s++) = (char) ender;
13883                         }
13884                     }
13885                 }
13886                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13887
13888                     /* Here are folding under /l, and the code point is
13889                      * problematic.  If this is the first character in the
13890                      * node, change the node type to folding.   Otherwise, if
13891                      * this is the first problematic character, close up the
13892                      * existing node, so can start a new node with this one */
13893                     if (! len) {
13894                         node_type = EXACTFL;
13895                     }
13896                     else if (node_type == EXACT) {
13897                         p = oldp;
13898                         goto loopdone;
13899                     }
13900
13901                     /* This code point means we can't simplify things */
13902                     maybe_exactfu = FALSE;
13903
13904                     /* A problematic code point in this context means that its
13905                      * fold isn't known until runtime, so we can't fold it now.
13906                      * (The non-problematic code points are the above-Latin1
13907                      * ones that fold to also all above-Latin1.  Their folds
13908                      * don't vary no matter what the locale is.) But here we
13909                      * have characters whose fold depends on the locale.
13910                      * Unlike the non-folding case above, we have to keep track
13911                      * of these in the sizing pass, so that we can make sure we
13912                      * don't split too-long nodes in the middle of a potential
13913                      * multi-char fold.  And unlike the regular fold case
13914                      * handled in the else clauses below, we don't actually
13915                      * fold and don't have special cases to consider.  What we
13916                      * do for both passes is the PASS2 code for non-folding */
13917                     goto not_fold_common;
13918                 }
13919                 else                /* A regular FOLD code point */
13920                      if (! UTF)
13921                 {
13922                     /* Here, are folding and are not UTF-8 encoded; therefore
13923                      * the character must be in the range 0-255, and is not /l.
13924                      * (Not /l because we already handled these under /l in
13925                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13926                     if (! IS_IN_SOME_FOLD_L1(ender)) {
13927
13928                         /* Start a new node for this non-folding character if
13929                          * previous ones in the node were folded */
13930                         if (len && node_type != EXACT) {
13931                             p = oldp;
13932                             goto loopdone;
13933                         }
13934
13935                         *(s++) = (char) ender;
13936                     }
13937                     else {  /* Here, does participate in some fold */
13938
13939                         /* if this is the first character in the node, change
13940                          * its type to folding.  Otherwise, if this is the
13941                          * first folding character in the node, close up the
13942                          * existing node, so can start a new node with this
13943                          * one.  */
13944                         if (! len) {
13945                             node_type = compute_EXACTish(pRExC_state);
13946                         }
13947                         else if (node_type == EXACT) {
13948                             p = oldp;
13949                             goto loopdone;
13950                         }
13951
13952                         /* See if the character's fold differs between /d and
13953                          * /u.  On non-ancient Unicode versions, this includes
13954                          * the multi-char fold SHARP S to 'ss' */
13955
13956 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13957    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13958                                       || UNICODE_DOT_DOT_VERSION > 0)
13959
13960                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13961
13962                             /* See comments for join_exact() as to why we fold
13963                              * this non-UTF at compile time */
13964                             if (node_type == EXACTFU) {
13965                                 *(s++) = 's';
13966
13967                                 /* Let the code below add in the extra 's' */
13968                                 ender = 's';
13969                                 added_len = 2;
13970                             }
13971                             else {
13972                                 RExC_seen_unfolded_sharp_s = 1;
13973                                 maybe_exactfu = FALSE;
13974                             }
13975                         }
13976                         else if (   len
13977                                  && isALPHA_FOLD_EQ(ender, 's')
13978                                  && isALPHA_FOLD_EQ(*(s-1), 's'))
13979                         {
13980                             maybe_exactfu = FALSE;
13981                         }
13982                         else
13983 #endif
13984
13985                         if (PL_fold[ender] != PL_fold_latin1[ender]) {
13986                             maybe_exactfu = FALSE;
13987                         }
13988
13989                         /* Even when folding, we store just the input
13990                          * character, as we have an array that finds its fold
13991                          * quickly */
13992                         *(s++) = (char) ender;
13993                     }
13994                 }
13995                 else {  /* FOLD, and UTF */
13996                     /* Unlike the non-fold case, we do actually have to
13997                      * calculate the fold in pass 1.  This is for two reasons,
13998                      * the folded length may be longer than the unfolded, and
13999                      * we have to calculate how many EXACTish nodes it will
14000                      * take; and we may run out of room in a node in the middle
14001                      * of a potential multi-char fold, and have to back off
14002                      * accordingly.  */
14003
14004                     if (isASCII_uni(ender)) {
14005
14006                         /* As above, we close up and start a new node if the
14007                          * previous characters don't match the fold/non-fold
14008                          * state of this one.  And if this is the first
14009                          * character in the node, and it folds, we change the
14010                          * node away from being EXACT */
14011                         if (! IS_IN_SOME_FOLD_L1(ender)) {
14012                             if (len && node_type != EXACT) {
14013                                 p = oldp;
14014                                 goto loopdone;
14015                             }
14016
14017                             *(s)++ = (U8) ender;
14018                         }
14019                         else {  /* Is in a fold */
14020
14021                             if (! len) {
14022                                 node_type = compute_EXACTish(pRExC_state);
14023                             }
14024                             else if (node_type == EXACT) {
14025                                 p = oldp;
14026                                 goto loopdone;
14027                             }
14028
14029                             *(s)++ = (U8) toFOLD(ender);
14030                         }
14031                     }
14032                     else {  /* Not ASCII */
14033                         STRLEN foldlen;
14034
14035                         /* As above, we close up and start a new node if the
14036                          * previous characters don't match the fold/non-fold
14037                          * state of this one.  And if this is the first
14038                          * character in the node, and it folds, we change the
14039                          * node away from being EXACT */
14040                         if (! _invlist_contains_cp(PL_utf8_foldable, ender)) {
14041                             if (len && node_type != EXACT) {
14042                                 p = oldp;
14043                                 goto loopdone;
14044                             }
14045
14046                             s = (char *) uvchr_to_utf8((U8 *) s, ender);
14047                             added_len = UVCHR_SKIP(ender);
14048                         }
14049                         else {
14050
14051                             if (! len) {
14052                                 node_type = compute_EXACTish(pRExC_state);
14053                             }
14054                             else if (node_type == EXACT) {
14055                                 p = oldp;
14056                                 goto loopdone;
14057                             }
14058
14059                             ender = _to_uni_fold_flags(
14060                                      ender,
14061                                      (U8 *) s,
14062                                      &foldlen,
14063                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
14064                                                         ? FOLD_FLAGS_NOMIX_ASCII
14065                                                         : 0));
14066                             s += foldlen;
14067                             added_len = foldlen;
14068                         }
14069                     }
14070                 }
14071
14072                 len += added_len;
14073
14074                 if (next_is_quantifier) {
14075
14076                     /* Here, the next input is a quantifier, and to get here,
14077                      * the current character is the only one in the node. */
14078                     goto loopdone;
14079                 }
14080
14081             } /* End of loop through literal characters */
14082
14083             /* Here we have either exhausted the input or ran out of room in
14084              * the node.  (If we encountered a character that can't be in the
14085              * node, transfer is made directly to <loopdone>, and so we
14086              * wouldn't have fallen off the end of the loop.)  In the latter
14087              * case, we artificially have to split the node into two, because
14088              * we just don't have enough space to hold everything.  This
14089              * creates a problem if the final character participates in a
14090              * multi-character fold in the non-final position, as a match that
14091              * should have occurred won't, due to the way nodes are matched,
14092              * and our artificial boundary.  So back off until we find a non-
14093              * problematic character -- one that isn't at the beginning or
14094              * middle of such a fold.  (Either it doesn't participate in any
14095              * folds, or appears only in the final position of all the folds it
14096              * does participate in.)  A better solution with far fewer false
14097              * positives, and that would fill the nodes more completely, would
14098              * be to actually have available all the multi-character folds to
14099              * test against, and to back-off only far enough to be sure that
14100              * this node isn't ending with a partial one.  <upper_parse> is set
14101              * further below (if we need to reparse the node) to include just
14102              * up through that final non-problematic character that this code
14103              * identifies, so when it is set to less than the full node, we can
14104              * skip the rest of this */
14105             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
14106
14107                 const STRLEN full_len = len;
14108
14109                 assert(len >= MAX_NODE_STRING_SIZE);
14110
14111                 /* Here, <s> points to the final byte of the final character.
14112                  * Look backwards through the string until find a non-
14113                  * problematic character */
14114
14115                 if (! UTF) {
14116
14117                     /* This has no multi-char folds to non-UTF characters */
14118                     if (ASCII_FOLD_RESTRICTED) {
14119                         goto loopdone;
14120                     }
14121
14122                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
14123                     len = s - s0 + 1;
14124                 }
14125                 else {
14126                     if (!  PL_NonL1NonFinalFold) {
14127                         PL_NonL1NonFinalFold = _new_invlist_C_array(
14128                                         NonL1_Perl_Non_Final_Folds_invlist);
14129                     }
14130
14131                     /* Point to the first byte of the final character */
14132                     s = (char *) utf8_hop((U8 *) s, -1);
14133
14134                     while (s >= s0) {   /* Search backwards until find
14135                                            a non-problematic char */
14136                         if (UTF8_IS_INVARIANT(*s)) {
14137
14138                             /* There are no ascii characters that participate
14139                              * in multi-char folds under /aa.  In EBCDIC, the
14140                              * non-ascii invariants are all control characters,
14141                              * so don't ever participate in any folds. */
14142                             if (ASCII_FOLD_RESTRICTED
14143                                 || ! IS_NON_FINAL_FOLD(*s))
14144                             {
14145                                 break;
14146                             }
14147                         }
14148                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
14149                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
14150                                                                   *s, *(s+1))))
14151                             {
14152                                 break;
14153                             }
14154                         }
14155                         else if (! _invlist_contains_cp(
14156                                         PL_NonL1NonFinalFold,
14157                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
14158                         {
14159                             break;
14160                         }
14161
14162                         /* Here, the current character is problematic in that
14163                          * it does occur in the non-final position of some
14164                          * fold, so try the character before it, but have to
14165                          * special case the very first byte in the string, so
14166                          * we don't read outside the string */
14167                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
14168                     } /* End of loop backwards through the string */
14169
14170                     /* If there were only problematic characters in the string,
14171                      * <s> will point to before s0, in which case the length
14172                      * should be 0, otherwise include the length of the
14173                      * non-problematic character just found */
14174                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
14175                 }
14176
14177                 /* Here, have found the final character, if any, that is
14178                  * non-problematic as far as ending the node without splitting
14179                  * it across a potential multi-char fold.  <len> contains the
14180                  * number of bytes in the node up-to and including that
14181                  * character, or is 0 if there is no such character, meaning
14182                  * the whole node contains only problematic characters.  In
14183                  * this case, give up and just take the node as-is.  We can't
14184                  * do any better */
14185                 if (len == 0) {
14186                     len = full_len;
14187
14188                     /* If the node ends in an 's' we make sure it stays EXACTF,
14189                      * as if it turns into an EXACTFU, it could later get
14190                      * joined with another 's' that would then wrongly match
14191                      * the sharp s */
14192                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
14193                     {
14194                         maybe_exactfu = FALSE;
14195                     }
14196                 } else {
14197
14198                     /* Here, the node does contain some characters that aren't
14199                      * problematic.  If one such is the final character in the
14200                      * node, we are done */
14201                     if (len == full_len) {
14202                         goto loopdone;
14203                     }
14204                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
14205
14206                         /* If the final character is problematic, but the
14207                          * penultimate is not, back-off that last character to
14208                          * later start a new node with it */
14209                         p = oldp;
14210                         goto loopdone;
14211                     }
14212
14213                     /* Here, the final non-problematic character is earlier
14214                      * in the input than the penultimate character.  What we do
14215                      * is reparse from the beginning, going up only as far as
14216                      * this final ok one, thus guaranteeing that the node ends
14217                      * in an acceptable character.  The reason we reparse is
14218                      * that we know how far in the character is, but we don't
14219                      * know how to correlate its position with the input parse.
14220                      * An alternate implementation would be to build that
14221                      * correlation as we go along during the original parse,
14222                      * but that would entail extra work for every node, whereas
14223                      * this code gets executed only when the string is too
14224                      * large for the node, and the final two characters are
14225                      * problematic, an infrequent occurrence.  Yet another
14226                      * possible strategy would be to save the tail of the
14227                      * string, and the next time regatom is called, initialize
14228                      * with that.  The problem with this is that unless you
14229                      * back off one more character, you won't be guaranteed
14230                      * regatom will get called again, unless regbranch,
14231                      * regpiece ... are also changed.  If you do back off that
14232                      * extra character, so that there is input guaranteed to
14233                      * force calling regatom, you can't handle the case where
14234                      * just the first character in the node is acceptable.  I
14235                      * (khw) decided to try this method which doesn't have that
14236                      * pitfall; if performance issues are found, we can do a
14237                      * combination of the current approach plus that one */
14238                     upper_parse = len;
14239                     len = 0;
14240                     s = s0;
14241                     goto reparse;
14242                 }
14243             }   /* End of verifying node ends with an appropriate char */
14244
14245           loopdone:   /* Jumped to when encounters something that shouldn't be
14246                          in the node */
14247
14248             /* I (khw) don't know if you can get here with zero length, but the
14249              * old code handled this situation by creating a zero-length EXACT
14250              * node.  Might as well be NOTHING instead */
14251             if (len == 0) {
14252                 OP(ret) = NOTHING;
14253             }
14254             else {
14255                 OP(ret) = node_type;
14256
14257                 /* If the node type is EXACT here, check to see if it
14258                  * should be EXACTL. */
14259                 if (node_type == EXACT) {
14260                     if (LOC) {
14261                         OP(ret) = EXACTL;
14262                     }
14263                 }
14264
14265                 if (FOLD) {
14266                     /* If 'maybe_exactfu' is set, then there are no code points
14267                      * that match differently depending on UTF8ness of the
14268                      * target string (for /u), or depending on locale for /l */
14269                     if (maybe_exactfu) {
14270                         if (node_type == EXACTF) {
14271                             OP(ret) = EXACTFU;
14272                         }
14273                         else if (node_type == EXACTFL) {
14274                             OP(ret) = EXACTFLU8;
14275                         }
14276                     }
14277                 }
14278
14279                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
14280                                            FALSE /* Don't look to see if could
14281                                                     be turned into an EXACT
14282                                                     node, as we have already
14283                                                     computed that */
14284                                           );
14285             }
14286
14287             RExC_parse = p - 1;
14288             Set_Node_Cur_Length(ret, parse_start);
14289             RExC_parse = p;
14290             {
14291                 /* len is STRLEN which is unsigned, need to copy to signed */
14292                 IV iv = len;
14293                 if (iv < 0)
14294                     vFAIL("Internal disaster");
14295             }
14296
14297         } /* End of label 'defchar:' */
14298         break;
14299     } /* End of giant switch on input character */
14300
14301     /* Position parse to next real character */
14302     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14303                                             FALSE /* Don't force to /x */ );
14304     if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
14305         ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here (and will be fatal in Perl 5.30), passed through");
14306     }
14307
14308     return(ret);
14309 }
14310
14311
14312 STATIC void
14313 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
14314 {
14315     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
14316      * sets up the bitmap and any flags, removing those code points from the
14317      * inversion list, setting it to NULL should it become completely empty */
14318
14319     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
14320     assert(PL_regkind[OP(node)] == ANYOF);
14321
14322     ANYOF_BITMAP_ZERO(node);
14323     if (*invlist_ptr) {
14324
14325         /* This gets set if we actually need to modify things */
14326         bool change_invlist = FALSE;
14327
14328         UV start, end;
14329
14330         /* Start looking through *invlist_ptr */
14331         invlist_iterinit(*invlist_ptr);
14332         while (invlist_iternext(*invlist_ptr, &start, &end)) {
14333             UV high;
14334             int i;
14335
14336             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
14337                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
14338             }
14339
14340             /* Quit if are above what we should change */
14341             if (start >= NUM_ANYOF_CODE_POINTS) {
14342                 break;
14343             }
14344
14345             change_invlist = TRUE;
14346
14347             /* Set all the bits in the range, up to the max that we are doing */
14348             high = (end < NUM_ANYOF_CODE_POINTS - 1)
14349                    ? end
14350                    : NUM_ANYOF_CODE_POINTS - 1;
14351             for (i = start; i <= (int) high; i++) {
14352                 if (! ANYOF_BITMAP_TEST(node, i)) {
14353                     ANYOF_BITMAP_SET(node, i);
14354                 }
14355             }
14356         }
14357         invlist_iterfinish(*invlist_ptr);
14358
14359         /* Done with loop; remove any code points that are in the bitmap from
14360          * *invlist_ptr; similarly for code points above the bitmap if we have
14361          * a flag to match all of them anyways */
14362         if (change_invlist) {
14363             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
14364         }
14365         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
14366             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
14367         }
14368
14369         /* If have completely emptied it, remove it completely */
14370         if (_invlist_len(*invlist_ptr) == 0) {
14371             SvREFCNT_dec_NN(*invlist_ptr);
14372             *invlist_ptr = NULL;
14373         }
14374     }
14375 }
14376
14377 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
14378    Character classes ([:foo:]) can also be negated ([:^foo:]).
14379    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
14380    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
14381    but trigger failures because they are currently unimplemented. */
14382
14383 #define POSIXCC_DONE(c)   ((c) == ':')
14384 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
14385 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
14386 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
14387
14388 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
14389 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
14390 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
14391
14392 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
14393
14394 /* 'posix_warnings' and 'warn_text' are names of variables in the following
14395  * routine. q.v. */
14396 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
14397         if (posix_warnings) {                                               \
14398             if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
14399             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                          \
14400                                              WARNING_PREFIX                 \
14401                                              text                           \
14402                                              REPORT_LOCATION,               \
14403                                              REPORT_LOCATION_ARGS(p)));     \
14404         }                                                                   \
14405     } STMT_END
14406 #define CLEAR_POSIX_WARNINGS()                                              \
14407     STMT_START {                                                            \
14408         if (posix_warnings && RExC_warn_text)                               \
14409             av_clear(RExC_warn_text);                                       \
14410     } STMT_END
14411
14412 #define CLEAR_POSIX_WARNINGS_AND_RETURN(ret)                                \
14413     STMT_START {                                                            \
14414         CLEAR_POSIX_WARNINGS();                                             \
14415         return ret;                                                         \
14416     } STMT_END
14417
14418 STATIC int
14419 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
14420
14421     const char * const s,      /* Where the putative posix class begins.
14422                                   Normally, this is one past the '['.  This
14423                                   parameter exists so it can be somewhere
14424                                   besides RExC_parse. */
14425     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
14426                                   NULL */
14427     AV ** posix_warnings,      /* Where to place any generated warnings, or
14428                                   NULL */
14429     const bool check_only      /* Don't die if error */
14430 )
14431 {
14432     /* This parses what the caller thinks may be one of the three POSIX
14433      * constructs:
14434      *  1) a character class, like [:blank:]
14435      *  2) a collating symbol, like [. .]
14436      *  3) an equivalence class, like [= =]
14437      * In the latter two cases, it croaks if it finds a syntactically legal
14438      * one, as these are not handled by Perl.
14439      *
14440      * The main purpose is to look for a POSIX character class.  It returns:
14441      *  a) the class number
14442      *      if it is a completely syntactically and semantically legal class.
14443      *      'updated_parse_ptr', if not NULL, is set to point to just after the
14444      *      closing ']' of the class
14445      *  b) OOB_NAMEDCLASS
14446      *      if it appears that one of the three POSIX constructs was meant, but
14447      *      its specification was somehow defective.  'updated_parse_ptr', if
14448      *      not NULL, is set to point to the character just after the end
14449      *      character of the class.  See below for handling of warnings.
14450      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
14451      *      if it  doesn't appear that a POSIX construct was intended.
14452      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
14453      *      raised.
14454      *
14455      * In b) there may be errors or warnings generated.  If 'check_only' is
14456      * TRUE, then any errors are discarded.  Warnings are returned to the
14457      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
14458      * instead it is NULL, warnings are suppressed.  This is done in all
14459      * passes.  The reason for this is that the rest of the parsing is heavily
14460      * dependent on whether this routine found a valid posix class or not.  If
14461      * it did, the closing ']' is absorbed as part of the class.  If no class,
14462      * or an invalid one is found, any ']' will be considered the terminator of
14463      * the outer bracketed character class, leading to very different results.
14464      * In particular, a '(?[ ])' construct will likely have a syntax error if
14465      * the class is parsed other than intended, and this will happen in pass1,
14466      * before the warnings would normally be output.  This mechanism allows the
14467      * caller to output those warnings in pass1 just before dieing, giving a
14468      * much better clue as to what is wrong.
14469      *
14470      * The reason for this function, and its complexity is that a bracketed
14471      * character class can contain just about anything.  But it's easy to
14472      * mistype the very specific posix class syntax but yielding a valid
14473      * regular bracketed class, so it silently gets compiled into something
14474      * quite unintended.
14475      *
14476      * The solution adopted here maintains backward compatibility except that
14477      * it adds a warning if it looks like a posix class was intended but
14478      * improperly specified.  The warning is not raised unless what is input
14479      * very closely resembles one of the 14 legal posix classes.  To do this,
14480      * it uses fuzzy parsing.  It calculates how many single-character edits it
14481      * would take to transform what was input into a legal posix class.  Only
14482      * if that number is quite small does it think that the intention was a
14483      * posix class.  Obviously these are heuristics, and there will be cases
14484      * where it errs on one side or another, and they can be tweaked as
14485      * experience informs.
14486      *
14487      * The syntax for a legal posix class is:
14488      *
14489      * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
14490      *
14491      * What this routine considers syntactically to be an intended posix class
14492      * is this (the comments indicate some restrictions that the pattern
14493      * doesn't show):
14494      *
14495      *  qr/(?x: \[?                         # The left bracket, possibly
14496      *                                      # omitted
14497      *          \h*                         # possibly followed by blanks
14498      *          (?: \^ \h* )?               # possibly a misplaced caret
14499      *          [:;]?                       # The opening class character,
14500      *                                      # possibly omitted.  A typo
14501      *                                      # semi-colon can also be used.
14502      *          \h*
14503      *          \^?                         # possibly a correctly placed
14504      *                                      # caret, but not if there was also
14505      *                                      # a misplaced one
14506      *          \h*
14507      *          .{3,15}                     # The class name.  If there are
14508      *                                      # deviations from the legal syntax,
14509      *                                      # its edit distance must be close
14510      *                                      # to a real class name in order
14511      *                                      # for it to be considered to be
14512      *                                      # an intended posix class.
14513      *          \h*
14514      *          [[:punct:]]?                # The closing class character,
14515      *                                      # possibly omitted.  If not a colon
14516      *                                      # nor semi colon, the class name
14517      *                                      # must be even closer to a valid
14518      *                                      # one
14519      *          \h*
14520      *          \]?                         # The right bracket, possibly
14521      *                                      # omitted.
14522      *     )/
14523      *
14524      * In the above, \h must be ASCII-only.
14525      *
14526      * These are heuristics, and can be tweaked as field experience dictates.
14527      * There will be cases when someone didn't intend to specify a posix class
14528      * that this warns as being so.  The goal is to minimize these, while
14529      * maximizing the catching of things intended to be a posix class that
14530      * aren't parsed as such.
14531      */
14532
14533     const char* p             = s;
14534     const char * const e      = RExC_end;
14535     unsigned complement       = 0;      /* If to complement the class */
14536     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
14537     bool has_opening_bracket  = FALSE;
14538     bool has_opening_colon    = FALSE;
14539     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
14540                                                    valid class */
14541     const char * possible_end = NULL;   /* used for a 2nd parse pass */
14542     const char* name_start;             /* ptr to class name first char */
14543
14544     /* If the number of single-character typos the input name is away from a
14545      * legal name is no more than this number, it is considered to have meant
14546      * the legal name */
14547     int max_distance          = 2;
14548
14549     /* to store the name.  The size determines the maximum length before we
14550      * decide that no posix class was intended.  Should be at least
14551      * sizeof("alphanumeric") */
14552     UV input_text[15];
14553     STATIC_ASSERT_DECL(C_ARRAY_LENGTH(input_text) >= sizeof "alphanumeric");
14554
14555     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
14556
14557     CLEAR_POSIX_WARNINGS();
14558
14559     if (p >= e) {
14560         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14561     }
14562
14563     if (*(p - 1) != '[') {
14564         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
14565         found_problem = TRUE;
14566     }
14567     else {
14568         has_opening_bracket = TRUE;
14569     }
14570
14571     /* They could be confused and think you can put spaces between the
14572      * components */
14573     if (isBLANK(*p)) {
14574         found_problem = TRUE;
14575
14576         do {
14577             p++;
14578         } while (p < e && isBLANK(*p));
14579
14580         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14581     }
14582
14583     /* For [. .] and [= =].  These are quite different internally from [: :],
14584      * so they are handled separately.  */
14585     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
14586                                             and 1 for at least one char in it
14587                                           */
14588     {
14589         const char open_char  = *p;
14590         const char * temp_ptr = p + 1;
14591
14592         /* These two constructs are not handled by perl, and if we find a
14593          * syntactically valid one, we croak.  khw, who wrote this code, finds
14594          * this explanation of them very unclear:
14595          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
14596          * And searching the rest of the internet wasn't very helpful either.
14597          * It looks like just about any byte can be in these constructs,
14598          * depending on the locale.  But unless the pattern is being compiled
14599          * under /l, which is very rare, Perl runs under the C or POSIX locale.
14600          * In that case, it looks like [= =] isn't allowed at all, and that
14601          * [. .] could be any single code point, but for longer strings the
14602          * constituent characters would have to be the ASCII alphabetics plus
14603          * the minus-hyphen.  Any sensible locale definition would limit itself
14604          * to these.  And any portable one definitely should.  Trying to parse
14605          * the general case is a nightmare (see [perl #127604]).  So, this code
14606          * looks only for interiors of these constructs that match:
14607          *      qr/.|[-\w]{2,}/
14608          * Using \w relaxes the apparent rules a little, without adding much
14609          * danger of mistaking something else for one of these constructs.
14610          *
14611          * [. .] in some implementations described on the internet is usable to
14612          * escape a character that otherwise is special in bracketed character
14613          * classes.  For example [.].] means a literal right bracket instead of
14614          * the ending of the class
14615          *
14616          * [= =] can legitimately contain a [. .] construct, but we don't
14617          * handle this case, as that [. .] construct will later get parsed
14618          * itself and croak then.  And [= =] is checked for even when not under
14619          * /l, as Perl has long done so.
14620          *
14621          * The code below relies on there being a trailing NUL, so it doesn't
14622          * have to keep checking if the parse ptr < e.
14623          */
14624         if (temp_ptr[1] == open_char) {
14625             temp_ptr++;
14626         }
14627         else while (    temp_ptr < e
14628                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
14629         {
14630             temp_ptr++;
14631         }
14632
14633         if (*temp_ptr == open_char) {
14634             temp_ptr++;
14635             if (*temp_ptr == ']') {
14636                 temp_ptr++;
14637                 if (! found_problem && ! check_only) {
14638                     RExC_parse = (char *) temp_ptr;
14639                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
14640                             "extensions", open_char, open_char);
14641                 }
14642
14643                 /* Here, the syntax wasn't completely valid, or else the call
14644                  * is to check-only */
14645                 if (updated_parse_ptr) {
14646                     *updated_parse_ptr = (char *) temp_ptr;
14647                 }
14648
14649                 CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
14650             }
14651         }
14652
14653         /* If we find something that started out to look like one of these
14654          * constructs, but isn't, we continue below so that it can be checked
14655          * for being a class name with a typo of '.' or '=' instead of a colon.
14656          * */
14657     }
14658
14659     /* Here, we think there is a possibility that a [: :] class was meant, and
14660      * we have the first real character.  It could be they think the '^' comes
14661      * first */
14662     if (*p == '^') {
14663         found_problem = TRUE;
14664         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
14665         complement = 1;
14666         p++;
14667
14668         if (isBLANK(*p)) {
14669             found_problem = TRUE;
14670
14671             do {
14672                 p++;
14673             } while (p < e && isBLANK(*p));
14674
14675             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14676         }
14677     }
14678
14679     /* But the first character should be a colon, which they could have easily
14680      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
14681      * distinguish from a colon, so treat that as a colon).  */
14682     if (*p == ':') {
14683         p++;
14684         has_opening_colon = TRUE;
14685     }
14686     else if (*p == ';') {
14687         found_problem = TRUE;
14688         p++;
14689         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14690         has_opening_colon = TRUE;
14691     }
14692     else {
14693         found_problem = TRUE;
14694         ADD_POSIX_WARNING(p, "there must be a starting ':'");
14695
14696         /* Consider an initial punctuation (not one of the recognized ones) to
14697          * be a left terminator */
14698         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
14699             p++;
14700         }
14701     }
14702
14703     /* They may think that you can put spaces between the components */
14704     if (isBLANK(*p)) {
14705         found_problem = TRUE;
14706
14707         do {
14708             p++;
14709         } while (p < e && isBLANK(*p));
14710
14711         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14712     }
14713
14714     if (*p == '^') {
14715
14716         /* We consider something like [^:^alnum:]] to not have been intended to
14717          * be a posix class, but XXX maybe we should */
14718         if (complement) {
14719             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14720         }
14721
14722         complement = 1;
14723         p++;
14724     }
14725
14726     /* Again, they may think that you can put spaces between the components */
14727     if (isBLANK(*p)) {
14728         found_problem = TRUE;
14729
14730         do {
14731             p++;
14732         } while (p < e && isBLANK(*p));
14733
14734         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14735     }
14736
14737     if (*p == ']') {
14738
14739         /* XXX This ']' may be a typo, and something else was meant.  But
14740          * treating it as such creates enough complications, that that
14741          * possibility isn't currently considered here.  So we assume that the
14742          * ']' is what is intended, and if we've already found an initial '[',
14743          * this leaves this construct looking like [:] or [:^], which almost
14744          * certainly weren't intended to be posix classes */
14745         if (has_opening_bracket) {
14746             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14747         }
14748
14749         /* But this function can be called when we parse the colon for
14750          * something like qr/[alpha:]]/, so we back up to look for the
14751          * beginning */
14752         p--;
14753
14754         if (*p == ';') {
14755             found_problem = TRUE;
14756             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14757         }
14758         else if (*p != ':') {
14759
14760             /* XXX We are currently very restrictive here, so this code doesn't
14761              * consider the possibility that, say, /[alpha.]]/ was intended to
14762              * be a posix class. */
14763             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14764         }
14765
14766         /* Here we have something like 'foo:]'.  There was no initial colon,
14767          * and we back up over 'foo.  XXX Unlike the going forward case, we
14768          * don't handle typos of non-word chars in the middle */
14769         has_opening_colon = FALSE;
14770         p--;
14771
14772         while (p > RExC_start && isWORDCHAR(*p)) {
14773             p--;
14774         }
14775         p++;
14776
14777         /* Here, we have positioned ourselves to where we think the first
14778          * character in the potential class is */
14779     }
14780
14781     /* Now the interior really starts.  There are certain key characters that
14782      * can end the interior, or these could just be typos.  To catch both
14783      * cases, we may have to do two passes.  In the first pass, we keep on
14784      * going unless we come to a sequence that matches
14785      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14786      * This means it takes a sequence to end the pass, so two typos in a row if
14787      * that wasn't what was intended.  If the class is perfectly formed, just
14788      * this one pass is needed.  We also stop if there are too many characters
14789      * being accumulated, but this number is deliberately set higher than any
14790      * real class.  It is set high enough so that someone who thinks that
14791      * 'alphanumeric' is a correct name would get warned that it wasn't.
14792      * While doing the pass, we keep track of where the key characters were in
14793      * it.  If we don't find an end to the class, and one of the key characters
14794      * was found, we redo the pass, but stop when we get to that character.
14795      * Thus the key character was considered a typo in the first pass, but a
14796      * terminator in the second.  If two key characters are found, we stop at
14797      * the second one in the first pass.  Again this can miss two typos, but
14798      * catches a single one
14799      *
14800      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14801      * point to the first key character.  For the second pass, it starts as -1.
14802      * */
14803
14804     name_start = p;
14805   parse_name:
14806     {
14807         bool has_blank               = FALSE;
14808         bool has_upper               = FALSE;
14809         bool has_terminating_colon   = FALSE;
14810         bool has_terminating_bracket = FALSE;
14811         bool has_semi_colon          = FALSE;
14812         unsigned int name_len        = 0;
14813         int punct_count              = 0;
14814
14815         while (p < e) {
14816
14817             /* Squeeze out blanks when looking up the class name below */
14818             if (isBLANK(*p) ) {
14819                 has_blank = TRUE;
14820                 found_problem = TRUE;
14821                 p++;
14822                 continue;
14823             }
14824
14825             /* The name will end with a punctuation */
14826             if (isPUNCT(*p)) {
14827                 const char * peek = p + 1;
14828
14829                 /* Treat any non-']' punctuation followed by a ']' (possibly
14830                  * with intervening blanks) as trying to terminate the class.
14831                  * ']]' is very likely to mean a class was intended (but
14832                  * missing the colon), but the warning message that gets
14833                  * generated shows the error position better if we exit the
14834                  * loop at the bottom (eventually), so skip it here. */
14835                 if (*p != ']') {
14836                     if (peek < e && isBLANK(*peek)) {
14837                         has_blank = TRUE;
14838                         found_problem = TRUE;
14839                         do {
14840                             peek++;
14841                         } while (peek < e && isBLANK(*peek));
14842                     }
14843
14844                     if (peek < e && *peek == ']') {
14845                         has_terminating_bracket = TRUE;
14846                         if (*p == ':') {
14847                             has_terminating_colon = TRUE;
14848                         }
14849                         else if (*p == ';') {
14850                             has_semi_colon = TRUE;
14851                             has_terminating_colon = TRUE;
14852                         }
14853                         else {
14854                             found_problem = TRUE;
14855                         }
14856                         p = peek + 1;
14857                         goto try_posix;
14858                     }
14859                 }
14860
14861                 /* Here we have punctuation we thought didn't end the class.
14862                  * Keep track of the position of the key characters that are
14863                  * more likely to have been class-enders */
14864                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14865
14866                     /* Allow just one such possible class-ender not actually
14867                      * ending the class. */
14868                     if (possible_end) {
14869                         break;
14870                     }
14871                     possible_end = p;
14872                 }
14873
14874                 /* If we have too many punctuation characters, no use in
14875                  * keeping going */
14876                 if (++punct_count > max_distance) {
14877                     break;
14878                 }
14879
14880                 /* Treat the punctuation as a typo. */
14881                 input_text[name_len++] = *p;
14882                 p++;
14883             }
14884             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14885                 input_text[name_len++] = toLOWER(*p);
14886                 has_upper = TRUE;
14887                 found_problem = TRUE;
14888                 p++;
14889             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14890                 input_text[name_len++] = *p;
14891                 p++;
14892             }
14893             else {
14894                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14895                 p+= UTF8SKIP(p);
14896             }
14897
14898             /* The declaration of 'input_text' is how long we allow a potential
14899              * class name to be, before saying they didn't mean a class name at
14900              * all */
14901             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14902                 break;
14903             }
14904         }
14905
14906         /* We get to here when the possible class name hasn't been properly
14907          * terminated before:
14908          *   1) we ran off the end of the pattern; or
14909          *   2) found two characters, each of which might have been intended to
14910          *      be the name's terminator
14911          *   3) found so many punctuation characters in the purported name,
14912          *      that the edit distance to a valid one is exceeded
14913          *   4) we decided it was more characters than anyone could have
14914          *      intended to be one. */
14915
14916         found_problem = TRUE;
14917
14918         /* In the final two cases, we know that looking up what we've
14919          * accumulated won't lead to a match, even a fuzzy one. */
14920         if (   name_len >= C_ARRAY_LENGTH(input_text)
14921             || punct_count > max_distance)
14922         {
14923             /* If there was an intermediate key character that could have been
14924              * an intended end, redo the parse, but stop there */
14925             if (possible_end && possible_end != (char *) -1) {
14926                 possible_end = (char *) -1; /* Special signal value to say
14927                                                we've done a first pass */
14928                 p = name_start;
14929                 goto parse_name;
14930             }
14931
14932             /* Otherwise, it can't have meant to have been a class */
14933             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14934         }
14935
14936         /* If we ran off the end, and the final character was a punctuation
14937          * one, back up one, to look at that final one just below.  Later, we
14938          * will restore the parse pointer if appropriate */
14939         if (name_len && p == e && isPUNCT(*(p-1))) {
14940             p--;
14941             name_len--;
14942         }
14943
14944         if (p < e && isPUNCT(*p)) {
14945             if (*p == ']') {
14946                 has_terminating_bracket = TRUE;
14947
14948                 /* If this is a 2nd ']', and the first one is just below this
14949                  * one, consider that to be the real terminator.  This gives a
14950                  * uniform and better positioning for the warning message  */
14951                 if (   possible_end
14952                     && possible_end != (char *) -1
14953                     && *possible_end == ']'
14954                     && name_len && input_text[name_len - 1] == ']')
14955                 {
14956                     name_len--;
14957                     p = possible_end;
14958
14959                     /* And this is actually equivalent to having done the 2nd
14960                      * pass now, so set it to not try again */
14961                     possible_end = (char *) -1;
14962                 }
14963             }
14964             else {
14965                 if (*p == ':') {
14966                     has_terminating_colon = TRUE;
14967                 }
14968                 else if (*p == ';') {
14969                     has_semi_colon = TRUE;
14970                     has_terminating_colon = TRUE;
14971                 }
14972                 p++;
14973             }
14974         }
14975
14976     try_posix:
14977
14978         /* Here, we have a class name to look up.  We can short circuit the
14979          * stuff below for short names that can't possibly be meant to be a
14980          * class name.  (We can do this on the first pass, as any second pass
14981          * will yield an even shorter name) */
14982         if (name_len < 3) {
14983             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14984         }
14985
14986         /* Find which class it is.  Initially switch on the length of the name.
14987          * */
14988         switch (name_len) {
14989             case 4:
14990                 if (memEQs(name_start, 4, "word")) {
14991                     /* this is not POSIX, this is the Perl \w */
14992                     class_number = ANYOF_WORDCHAR;
14993                 }
14994                 break;
14995             case 5:
14996                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14997                  *                        graph lower print punct space upper
14998                  * Offset 4 gives the best switch position.  */
14999                 switch (name_start[4]) {
15000                     case 'a':
15001                         if (memBEGINs(name_start, 5, "alph")) /* alpha */
15002                             class_number = ANYOF_ALPHA;
15003                         break;
15004                     case 'e':
15005                         if (memBEGINs(name_start, 5, "spac")) /* space */
15006                             class_number = ANYOF_SPACE;
15007                         break;
15008                     case 'h':
15009                         if (memBEGINs(name_start, 5, "grap")) /* graph */
15010                             class_number = ANYOF_GRAPH;
15011                         break;
15012                     case 'i':
15013                         if (memBEGINs(name_start, 5, "asci")) /* ascii */
15014                             class_number = ANYOF_ASCII;
15015                         break;
15016                     case 'k':
15017                         if (memBEGINs(name_start, 5, "blan")) /* blank */
15018                             class_number = ANYOF_BLANK;
15019                         break;
15020                     case 'l':
15021                         if (memBEGINs(name_start, 5, "cntr")) /* cntrl */
15022                             class_number = ANYOF_CNTRL;
15023                         break;
15024                     case 'm':
15025                         if (memBEGINs(name_start, 5, "alnu")) /* alnum */
15026                             class_number = ANYOF_ALPHANUMERIC;
15027                         break;
15028                     case 'r':
15029                         if (memBEGINs(name_start, 5, "lowe")) /* lower */
15030                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
15031                         else if (memBEGINs(name_start, 5, "uppe")) /* upper */
15032                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
15033                         break;
15034                     case 't':
15035                         if (memBEGINs(name_start, 5, "digi")) /* digit */
15036                             class_number = ANYOF_DIGIT;
15037                         else if (memBEGINs(name_start, 5, "prin")) /* print */
15038                             class_number = ANYOF_PRINT;
15039                         else if (memBEGINs(name_start, 5, "punc")) /* punct */
15040                             class_number = ANYOF_PUNCT;
15041                         break;
15042                 }
15043                 break;
15044             case 6:
15045                 if (memEQs(name_start, 6, "xdigit"))
15046                     class_number = ANYOF_XDIGIT;
15047                 break;
15048         }
15049
15050         /* If the name exactly matches a posix class name the class number will
15051          * here be set to it, and the input almost certainly was meant to be a
15052          * posix class, so we can skip further checking.  If instead the syntax
15053          * is exactly correct, but the name isn't one of the legal ones, we
15054          * will return that as an error below.  But if neither of these apply,
15055          * it could be that no posix class was intended at all, or that one
15056          * was, but there was a typo.  We tease these apart by doing fuzzy
15057          * matching on the name */
15058         if (class_number == OOB_NAMEDCLASS && found_problem) {
15059             const UV posix_names[][6] = {
15060                                                 { 'a', 'l', 'n', 'u', 'm' },
15061                                                 { 'a', 'l', 'p', 'h', 'a' },
15062                                                 { 'a', 's', 'c', 'i', 'i' },
15063                                                 { 'b', 'l', 'a', 'n', 'k' },
15064                                                 { 'c', 'n', 't', 'r', 'l' },
15065                                                 { 'd', 'i', 'g', 'i', 't' },
15066                                                 { 'g', 'r', 'a', 'p', 'h' },
15067                                                 { 'l', 'o', 'w', 'e', 'r' },
15068                                                 { 'p', 'r', 'i', 'n', 't' },
15069                                                 { 'p', 'u', 'n', 'c', 't' },
15070                                                 { 's', 'p', 'a', 'c', 'e' },
15071                                                 { 'u', 'p', 'p', 'e', 'r' },
15072                                                 { 'w', 'o', 'r', 'd' },
15073                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
15074                                             };
15075             /* The names of the above all have added NULs to make them the same
15076              * size, so we need to also have the real lengths */
15077             const UV posix_name_lengths[] = {
15078                                                 sizeof("alnum") - 1,
15079                                                 sizeof("alpha") - 1,
15080                                                 sizeof("ascii") - 1,
15081                                                 sizeof("blank") - 1,
15082                                                 sizeof("cntrl") - 1,
15083                                                 sizeof("digit") - 1,
15084                                                 sizeof("graph") - 1,
15085                                                 sizeof("lower") - 1,
15086                                                 sizeof("print") - 1,
15087                                                 sizeof("punct") - 1,
15088                                                 sizeof("space") - 1,
15089                                                 sizeof("upper") - 1,
15090                                                 sizeof("word")  - 1,
15091                                                 sizeof("xdigit")- 1
15092                                             };
15093             unsigned int i;
15094             int temp_max = max_distance;    /* Use a temporary, so if we
15095                                                reparse, we haven't changed the
15096                                                outer one */
15097
15098             /* Use a smaller max edit distance if we are missing one of the
15099              * delimiters */
15100             if (   has_opening_bracket + has_opening_colon < 2
15101                 || has_terminating_bracket + has_terminating_colon < 2)
15102             {
15103                 temp_max--;
15104             }
15105
15106             /* See if the input name is close to a legal one */
15107             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
15108
15109                 /* Short circuit call if the lengths are too far apart to be
15110                  * able to match */
15111                 if (abs( (int) (name_len - posix_name_lengths[i]))
15112                     > temp_max)
15113                 {
15114                     continue;
15115                 }
15116
15117                 if (edit_distance(input_text,
15118                                   posix_names[i],
15119                                   name_len,
15120                                   posix_name_lengths[i],
15121                                   temp_max
15122                                  )
15123                     > -1)
15124                 { /* If it is close, it probably was intended to be a class */
15125                     goto probably_meant_to_be;
15126                 }
15127             }
15128
15129             /* Here the input name is not close enough to a valid class name
15130              * for us to consider it to be intended to be a posix class.  If
15131              * we haven't already done so, and the parse found a character that
15132              * could have been terminators for the name, but which we absorbed
15133              * as typos during the first pass, repeat the parse, signalling it
15134              * to stop at that character */
15135             if (possible_end && possible_end != (char *) -1) {
15136                 possible_end = (char *) -1;
15137                 p = name_start;
15138                 goto parse_name;
15139             }
15140
15141             /* Here neither pass found a close-enough class name */
15142             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15143         }
15144
15145     probably_meant_to_be:
15146
15147         /* Here we think that a posix specification was intended.  Update any
15148          * parse pointer */
15149         if (updated_parse_ptr) {
15150             *updated_parse_ptr = (char *) p;
15151         }
15152
15153         /* If a posix class name was intended but incorrectly specified, we
15154          * output or return the warnings */
15155         if (found_problem) {
15156
15157             /* We set flags for these issues in the parse loop above instead of
15158              * adding them to the list of warnings, because we can parse it
15159              * twice, and we only want one warning instance */
15160             if (has_upper) {
15161                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
15162             }
15163             if (has_blank) {
15164                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15165             }
15166             if (has_semi_colon) {
15167                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15168             }
15169             else if (! has_terminating_colon) {
15170                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
15171             }
15172             if (! has_terminating_bracket) {
15173                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
15174             }
15175
15176             if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
15177                 *posix_warnings = RExC_warn_text;
15178             }
15179         }
15180         else if (class_number != OOB_NAMEDCLASS) {
15181             /* If it is a known class, return the class.  The class number
15182              * #defines are structured so each complement is +1 to the normal
15183              * one */
15184             CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
15185         }
15186         else if (! check_only) {
15187
15188             /* Here, it is an unrecognized class.  This is an error (unless the
15189             * call is to check only, which we've already handled above) */
15190             const char * const complement_string = (complement)
15191                                                    ? "^"
15192                                                    : "";
15193             RExC_parse = (char *) p;
15194             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
15195                         complement_string,
15196                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
15197         }
15198     }
15199
15200     return OOB_NAMEDCLASS;
15201 }
15202 #undef ADD_POSIX_WARNING
15203
15204 STATIC unsigned  int
15205 S_regex_set_precedence(const U8 my_operator) {
15206
15207     /* Returns the precedence in the (?[...]) construct of the input operator,
15208      * specified by its character representation.  The precedence follows
15209      * general Perl rules, but it extends this so that ')' and ']' have (low)
15210      * precedence even though they aren't really operators */
15211
15212     switch (my_operator) {
15213         case '!':
15214             return 5;
15215         case '&':
15216             return 4;
15217         case '^':
15218         case '|':
15219         case '+':
15220         case '-':
15221             return 3;
15222         case ')':
15223             return 2;
15224         case ']':
15225             return 1;
15226     }
15227
15228     NOT_REACHED; /* NOTREACHED */
15229     return 0;   /* Silence compiler warning */
15230 }
15231
15232 STATIC regnode *
15233 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
15234                     I32 *flagp, U32 depth,
15235                     char * const oregcomp_parse)
15236 {
15237     /* Handle the (?[...]) construct to do set operations */
15238
15239     U8 curchar;                     /* Current character being parsed */
15240     UV start, end;                  /* End points of code point ranges */
15241     SV* final = NULL;               /* The end result inversion list */
15242     SV* result_string;              /* 'final' stringified */
15243     AV* stack;                      /* stack of operators and operands not yet
15244                                        resolved */
15245     AV* fence_stack = NULL;         /* A stack containing the positions in
15246                                        'stack' of where the undealt-with left
15247                                        parens would be if they were actually
15248                                        put there */
15249     /* The 'volatile' is a workaround for an optimiser bug
15250      * in Solaris Studio 12.3. See RT #127455 */
15251     volatile IV fence = 0;          /* Position of where most recent undealt-
15252                                        with left paren in stack is; -1 if none.
15253                                      */
15254     STRLEN len;                     /* Temporary */
15255     regnode* node;                  /* Temporary, and final regnode returned by
15256                                        this function */
15257     const bool save_fold = FOLD;    /* Temporary */
15258     char *save_end, *save_parse;    /* Temporaries */
15259     const bool in_locale = LOC;     /* we turn off /l during processing */
15260     AV* posix_warnings = NULL;
15261
15262     GET_RE_DEBUG_FLAGS_DECL;
15263
15264     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
15265
15266     DEBUG_PARSE("xcls");
15267
15268     if (in_locale) {
15269         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
15270     }
15271
15272     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
15273                                          This is required so that the compile
15274                                          time values are valid in all runtime
15275                                          cases */
15276
15277     /* This will return only an ANYOF regnode, or (unlikely) something smaller
15278      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
15279      * call regclass to handle '[]' so as to not have to reinvent its parsing
15280      * rules here (throwing away the size it computes each time).  And, we exit
15281      * upon an unescaped ']' that isn't one ending a regclass.  To do both
15282      * these things, we need to realize that something preceded by a backslash
15283      * is escaped, so we have to keep track of backslashes */
15284     if (SIZE_ONLY) {
15285         UV nest_depth = 0; /* how many nested (?[...]) constructs */
15286
15287         while (RExC_parse < RExC_end) {
15288             SV* current = NULL;
15289
15290             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15291                                     TRUE /* Force /x */ );
15292
15293             switch (*RExC_parse) {
15294                 case '(':
15295                     if (RExC_parse[1] == '?' && RExC_parse[2] == '[')
15296                         nest_depth++, RExC_parse+=2;
15297                     /* FALLTHROUGH */
15298                 default:
15299                     break;
15300                 case '\\':
15301                     /* Skip past this, so the next character gets skipped, after
15302                      * the switch */
15303                     RExC_parse++;
15304                     if (*RExC_parse == 'c') {
15305                             /* Skip the \cX notation for control characters */
15306                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
15307                     }
15308                     break;
15309
15310                 case '[':
15311                 {
15312                     /* See if this is a [:posix:] class. */
15313                     bool is_posix_class = (OOB_NAMEDCLASS
15314                             < handle_possible_posix(pRExC_state,
15315                                                 RExC_parse + 1,
15316                                                 NULL,
15317                                                 NULL,
15318                                                 TRUE /* checking only */));
15319                     /* If it is a posix class, leave the parse pointer at the
15320                      * '[' to fool regclass() into thinking it is part of a
15321                      * '[[:posix:]]'. */
15322                     if (! is_posix_class) {
15323                         RExC_parse++;
15324                     }
15325
15326                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
15327                      * if multi-char folds are allowed.  */
15328                     if (!regclass(pRExC_state, flagp,depth+1,
15329                                   is_posix_class, /* parse the whole char
15330                                                      class only if not a
15331                                                      posix class */
15332                                   FALSE, /* don't allow multi-char folds */
15333                                   TRUE, /* silence non-portable warnings. */
15334                                   TRUE, /* strict */
15335                                   FALSE, /* Require return to be an ANYOF */
15336                                   &current,
15337                                   &posix_warnings
15338                                  ))
15339                         FAIL2("panic: regclass returned NULL to handle_sets, "
15340                               "flags=%#" UVxf, (UV) *flagp);
15341
15342                     /* function call leaves parse pointing to the ']', except
15343                      * if we faked it */
15344                     if (is_posix_class) {
15345                         RExC_parse--;
15346                     }
15347
15348                     SvREFCNT_dec(current);   /* In case it returned something */
15349                     break;
15350                 }
15351
15352                 case ']':
15353                     if (RExC_parse[1] == ')') {
15354                         RExC_parse++;
15355                         if (nest_depth--) break;
15356                         node = reganode(pRExC_state, ANYOF, 0);
15357                         RExC_size += ANYOF_SKIP;
15358                         nextchar(pRExC_state);
15359                         Set_Node_Length(node,
15360                                 RExC_parse - oregcomp_parse + 1); /* MJD */
15361                         if (in_locale) {
15362                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15363                         }
15364
15365                         return node;
15366                     }
15367                     /* We output the messages even if warnings are off, because we'll fail
15368                      * the very next thing, and these give a likely diagnosis for that */
15369                     if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
15370                         output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
15371                     }
15372                     RExC_parse++;
15373                     vFAIL("Unexpected ']' with no following ')' in (?[...");
15374             }
15375
15376             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
15377         }
15378
15379         /* We output the messages even if warnings are off, because we'll fail
15380          * the very next thing, and these give a likely diagnosis for that */
15381         if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
15382             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
15383         }
15384
15385         vFAIL("Syntax error in (?[...])");
15386     }
15387
15388     /* Pass 2 only after this. */
15389     Perl_ck_warner_d(aTHX_
15390         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
15391         "The regex_sets feature is experimental" REPORT_LOCATION,
15392         REPORT_LOCATION_ARGS(RExC_parse));
15393
15394     /* Everything in this construct is a metacharacter.  Operands begin with
15395      * either a '\' (for an escape sequence), or a '[' for a bracketed
15396      * character class.  Any other character should be an operator, or
15397      * parenthesis for grouping.  Both types of operands are handled by calling
15398      * regclass() to parse them.  It is called with a parameter to indicate to
15399      * return the computed inversion list.  The parsing here is implemented via
15400      * a stack.  Each entry on the stack is a single character representing one
15401      * of the operators; or else a pointer to an operand inversion list. */
15402
15403 #define IS_OPERATOR(a) SvIOK(a)
15404 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
15405
15406     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
15407      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
15408      * with pronouncing it called it Reverse Polish instead, but now that YOU
15409      * know how to pronounce it you can use the correct term, thus giving due
15410      * credit to the person who invented it, and impressing your geek friends.
15411      * Wikipedia says that the pronounciation of "Ł" has been changing so that
15412      * it is now more like an English initial W (as in wonk) than an L.)
15413      *
15414      * This means that, for example, 'a | b & c' is stored on the stack as
15415      *
15416      * c  [4]
15417      * b  [3]
15418      * &  [2]
15419      * a  [1]
15420      * |  [0]
15421      *
15422      * where the numbers in brackets give the stack [array] element number.
15423      * In this implementation, parentheses are not stored on the stack.
15424      * Instead a '(' creates a "fence" so that the part of the stack below the
15425      * fence is invisible except to the corresponding ')' (this allows us to
15426      * replace testing for parens, by using instead subtraction of the fence
15427      * position).  As new operands are processed they are pushed onto the stack
15428      * (except as noted in the next paragraph).  New operators of higher
15429      * precedence than the current final one are inserted on the stack before
15430      * the lhs operand (so that when the rhs is pushed next, everything will be
15431      * in the correct positions shown above.  When an operator of equal or
15432      * lower precedence is encountered in parsing, all the stacked operations
15433      * of equal or higher precedence are evaluated, leaving the result as the
15434      * top entry on the stack.  This makes higher precedence operations
15435      * evaluate before lower precedence ones, and causes operations of equal
15436      * precedence to left associate.
15437      *
15438      * The only unary operator '!' is immediately pushed onto the stack when
15439      * encountered.  When an operand is encountered, if the top of the stack is
15440      * a '!", the complement is immediately performed, and the '!' popped.  The
15441      * resulting value is treated as a new operand, and the logic in the
15442      * previous paragraph is executed.  Thus in the expression
15443      *      [a] + ! [b]
15444      * the stack looks like
15445      *
15446      * !
15447      * a
15448      * +
15449      *
15450      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
15451      * becomes
15452      *
15453      * !b
15454      * a
15455      * +
15456      *
15457      * A ')' is treated as an operator with lower precedence than all the
15458      * aforementioned ones, which causes all operations on the stack above the
15459      * corresponding '(' to be evaluated down to a single resultant operand.
15460      * Then the fence for the '(' is removed, and the operand goes through the
15461      * algorithm above, without the fence.
15462      *
15463      * A separate stack is kept of the fence positions, so that the position of
15464      * the latest so-far unbalanced '(' is at the top of it.
15465      *
15466      * The ']' ending the construct is treated as the lowest operator of all,
15467      * so that everything gets evaluated down to a single operand, which is the
15468      * result */
15469
15470     sv_2mortal((SV *)(stack = newAV()));
15471     sv_2mortal((SV *)(fence_stack = newAV()));
15472
15473     while (RExC_parse < RExC_end) {
15474         I32 top_index;              /* Index of top-most element in 'stack' */
15475         SV** top_ptr;               /* Pointer to top 'stack' element */
15476         SV* current = NULL;         /* To contain the current inversion list
15477                                        operand */
15478         SV* only_to_avoid_leaks;
15479
15480         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15481                                 TRUE /* Force /x */ );
15482         if (RExC_parse >= RExC_end) {
15483             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
15484         }
15485
15486         curchar = UCHARAT(RExC_parse);
15487
15488 redo_curchar:
15489
15490 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15491                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
15492         DEBUG_U(dump_regex_sets_structures(pRExC_state,
15493                                            stack, fence, fence_stack));
15494 #endif
15495
15496         top_index = av_tindex_skip_len_mg(stack);
15497
15498         switch (curchar) {
15499             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
15500             char stacked_operator;  /* The topmost operator on the 'stack'. */
15501             SV* lhs;                /* Operand to the left of the operator */
15502             SV* rhs;                /* Operand to the right of the operator */
15503             SV* fence_ptr;          /* Pointer to top element of the fence
15504                                        stack */
15505
15506             case '(':
15507
15508                 if (   RExC_parse < RExC_end - 1
15509                     && (UCHARAT(RExC_parse + 1) == '?'))
15510                 {
15511                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
15512                      * This happens when we have some thing like
15513                      *
15514                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
15515                      *   ...
15516                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
15517                      *
15518                      * Here we would be handling the interpolated
15519                      * '$thai_or_lao'.  We handle this by a recursive call to
15520                      * ourselves which returns the inversion list the
15521                      * interpolated expression evaluates to.  We use the flags
15522                      * from the interpolated pattern. */
15523                     U32 save_flags = RExC_flags;
15524                     const char * save_parse;
15525
15526                     RExC_parse += 2;        /* Skip past the '(?' */
15527                     save_parse = RExC_parse;
15528
15529                     /* Parse any flags for the '(?' */
15530                     parse_lparen_question_flags(pRExC_state);
15531
15532                     if (RExC_parse == save_parse  /* Makes sure there was at
15533                                                      least one flag (or else
15534                                                      this embedding wasn't
15535                                                      compiled) */
15536                         || RExC_parse >= RExC_end - 4
15537                         || UCHARAT(RExC_parse) != ':'
15538                         || UCHARAT(++RExC_parse) != '('
15539                         || UCHARAT(++RExC_parse) != '?'
15540                         || UCHARAT(++RExC_parse) != '[')
15541                     {
15542
15543                         /* In combination with the above, this moves the
15544                          * pointer to the point just after the first erroneous
15545                          * character (or if there are no flags, to where they
15546                          * should have been) */
15547                         if (RExC_parse >= RExC_end - 4) {
15548                             RExC_parse = RExC_end;
15549                         }
15550                         else if (RExC_parse != save_parse) {
15551                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15552                         }
15553                         vFAIL("Expecting '(?flags:(?[...'");
15554                     }
15555
15556                     /* Recurse, with the meat of the embedded expression */
15557                     RExC_parse++;
15558                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15559                                                     depth+1, oregcomp_parse);
15560
15561                     /* Here, 'current' contains the embedded expression's
15562                      * inversion list, and RExC_parse points to the trailing
15563                      * ']'; the next character should be the ')' */
15564                     RExC_parse++;
15565                     if (UCHARAT(RExC_parse) != ')')
15566                         vFAIL("Expecting close paren for nested extended charclass");
15567
15568                     /* Then the ')' matching the original '(' handled by this
15569                      * case: statement */
15570                     RExC_parse++;
15571                     if (UCHARAT(RExC_parse) != ')')
15572                         vFAIL("Expecting close paren for wrapper for nested extended charclass");
15573
15574                     RExC_parse++;
15575                     RExC_flags = save_flags;
15576                     goto handle_operand;
15577                 }
15578
15579                 /* A regular '('.  Look behind for illegal syntax */
15580                 if (top_index - fence >= 0) {
15581                     /* If the top entry on the stack is an operator, it had
15582                      * better be a '!', otherwise the entry below the top
15583                      * operand should be an operator */
15584                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15585                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15586                         || (   IS_OPERAND(*top_ptr)
15587                             && (   top_index - fence < 1
15588                                 || ! (stacked_ptr = av_fetch(stack,
15589                                                              top_index - 1,
15590                                                              FALSE))
15591                                 || ! IS_OPERATOR(*stacked_ptr))))
15592                     {
15593                         RExC_parse++;
15594                         vFAIL("Unexpected '(' with no preceding operator");
15595                     }
15596                 }
15597
15598                 /* Stack the position of this undealt-with left paren */
15599                 av_push(fence_stack, newSViv(fence));
15600                 fence = top_index + 1;
15601                 break;
15602
15603             case '\\':
15604                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15605                  * multi-char folds are allowed.  */
15606                 if (!regclass(pRExC_state, flagp,depth+1,
15607                               TRUE, /* means parse just the next thing */
15608                               FALSE, /* don't allow multi-char folds */
15609                               FALSE, /* don't silence non-portable warnings.  */
15610                               TRUE,  /* strict */
15611                               FALSE, /* Require return to be an ANYOF */
15612                               &current,
15613                               NULL))
15614                 {
15615                     FAIL2("panic: regclass returned NULL to handle_sets, "
15616                           "flags=%#" UVxf, (UV) *flagp);
15617                 }
15618
15619                 /* regclass() will return with parsing just the \ sequence,
15620                  * leaving the parse pointer at the next thing to parse */
15621                 RExC_parse--;
15622                 goto handle_operand;
15623
15624             case '[':   /* Is a bracketed character class */
15625             {
15626                 /* See if this is a [:posix:] class. */
15627                 bool is_posix_class = (OOB_NAMEDCLASS
15628                             < handle_possible_posix(pRExC_state,
15629                                                 RExC_parse + 1,
15630                                                 NULL,
15631                                                 NULL,
15632                                                 TRUE /* checking only */));
15633                 /* If it is a posix class, leave the parse pointer at the '['
15634                  * to fool regclass() into thinking it is part of a
15635                  * '[[:posix:]]'. */
15636                 if (! is_posix_class) {
15637                     RExC_parse++;
15638                 }
15639
15640                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15641                  * multi-char folds are allowed.  */
15642                 if (!regclass(pRExC_state, flagp,depth+1,
15643                                 is_posix_class, /* parse the whole char
15644                                                     class only if not a
15645                                                     posix class */
15646                                 FALSE, /* don't allow multi-char folds */
15647                                 TRUE, /* silence non-portable warnings. */
15648                                 TRUE, /* strict */
15649                                 FALSE, /* Require return to be an ANYOF */
15650                                 &current,
15651                                 NULL
15652                                 ))
15653                 {
15654                     FAIL2("panic: regclass returned NULL to handle_sets, "
15655                           "flags=%#" UVxf, (UV) *flagp);
15656                 }
15657
15658                 /* function call leaves parse pointing to the ']', except if we
15659                  * faked it */
15660                 if (is_posix_class) {
15661                     RExC_parse--;
15662                 }
15663
15664                 goto handle_operand;
15665             }
15666
15667             case ']':
15668                 if (top_index >= 1) {
15669                     goto join_operators;
15670                 }
15671
15672                 /* Only a single operand on the stack: are done */
15673                 goto done;
15674
15675             case ')':
15676                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
15677                     RExC_parse++;
15678                     vFAIL("Unexpected ')'");
15679                 }
15680
15681                 /* If nothing after the fence, is missing an operand */
15682                 if (top_index - fence < 0) {
15683                     RExC_parse++;
15684                     goto bad_syntax;
15685                 }
15686                 /* If at least two things on the stack, treat this as an
15687                   * operator */
15688                 if (top_index - fence >= 1) {
15689                     goto join_operators;
15690                 }
15691
15692                 /* Here only a single thing on the fenced stack, and there is a
15693                  * fence.  Get rid of it */
15694                 fence_ptr = av_pop(fence_stack);
15695                 assert(fence_ptr);
15696                 fence = SvIV(fence_ptr) - 1;
15697                 SvREFCNT_dec_NN(fence_ptr);
15698                 fence_ptr = NULL;
15699
15700                 if (fence < 0) {
15701                     fence = 0;
15702                 }
15703
15704                 /* Having gotten rid of the fence, we pop the operand at the
15705                  * stack top and process it as a newly encountered operand */
15706                 current = av_pop(stack);
15707                 if (IS_OPERAND(current)) {
15708                     goto handle_operand;
15709                 }
15710
15711                 RExC_parse++;
15712                 goto bad_syntax;
15713
15714             case '&':
15715             case '|':
15716             case '+':
15717             case '-':
15718             case '^':
15719
15720                 /* These binary operators should have a left operand already
15721                  * parsed */
15722                 if (   top_index - fence < 0
15723                     || top_index - fence == 1
15724                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15725                     || ! IS_OPERAND(*top_ptr))
15726                 {
15727                     goto unexpected_binary;
15728                 }
15729
15730                 /* If only the one operand is on the part of the stack visible
15731                  * to us, we just place this operator in the proper position */
15732                 if (top_index - fence < 2) {
15733
15734                     /* Place the operator before the operand */
15735
15736                     SV* lhs = av_pop(stack);
15737                     av_push(stack, newSVuv(curchar));
15738                     av_push(stack, lhs);
15739                     break;
15740                 }
15741
15742                 /* But if there is something else on the stack, we need to
15743                  * process it before this new operator if and only if the
15744                  * stacked operation has equal or higher precedence than the
15745                  * new one */
15746
15747              join_operators:
15748
15749                 /* The operator on the stack is supposed to be below both its
15750                  * operands */
15751                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15752                     || IS_OPERAND(*stacked_ptr))
15753                 {
15754                     /* But if not, it's legal and indicates we are completely
15755                      * done if and only if we're currently processing a ']',
15756                      * which should be the final thing in the expression */
15757                     if (curchar == ']') {
15758                         goto done;
15759                     }
15760
15761                   unexpected_binary:
15762                     RExC_parse++;
15763                     vFAIL2("Unexpected binary operator '%c' with no "
15764                            "preceding operand", curchar);
15765                 }
15766                 stacked_operator = (char) SvUV(*stacked_ptr);
15767
15768                 if (regex_set_precedence(curchar)
15769                     > regex_set_precedence(stacked_operator))
15770                 {
15771                     /* Here, the new operator has higher precedence than the
15772                      * stacked one.  This means we need to add the new one to
15773                      * the stack to await its rhs operand (and maybe more
15774                      * stuff).  We put it before the lhs operand, leaving
15775                      * untouched the stacked operator and everything below it
15776                      * */
15777                     lhs = av_pop(stack);
15778                     assert(IS_OPERAND(lhs));
15779
15780                     av_push(stack, newSVuv(curchar));
15781                     av_push(stack, lhs);
15782                     break;
15783                 }
15784
15785                 /* Here, the new operator has equal or lower precedence than
15786                  * what's already there.  This means the operation already
15787                  * there should be performed now, before the new one. */
15788
15789                 rhs = av_pop(stack);
15790                 if (! IS_OPERAND(rhs)) {
15791
15792                     /* This can happen when a ! is not followed by an operand,
15793                      * like in /(?[\t &!])/ */
15794                     goto bad_syntax;
15795                 }
15796
15797                 lhs = av_pop(stack);
15798
15799                 if (! IS_OPERAND(lhs)) {
15800
15801                     /* This can happen when there is an empty (), like in
15802                      * /(?[[0]+()+])/ */
15803                     goto bad_syntax;
15804                 }
15805
15806                 switch (stacked_operator) {
15807                     case '&':
15808                         _invlist_intersection(lhs, rhs, &rhs);
15809                         break;
15810
15811                     case '|':
15812                     case '+':
15813                         _invlist_union(lhs, rhs, &rhs);
15814                         break;
15815
15816                     case '-':
15817                         _invlist_subtract(lhs, rhs, &rhs);
15818                         break;
15819
15820                     case '^':   /* The union minus the intersection */
15821                     {
15822                         SV* i = NULL;
15823                         SV* u = NULL;
15824
15825                         _invlist_union(lhs, rhs, &u);
15826                         _invlist_intersection(lhs, rhs, &i);
15827                         _invlist_subtract(u, i, &rhs);
15828                         SvREFCNT_dec_NN(i);
15829                         SvREFCNT_dec_NN(u);
15830                         break;
15831                     }
15832                 }
15833                 SvREFCNT_dec(lhs);
15834
15835                 /* Here, the higher precedence operation has been done, and the
15836                  * result is in 'rhs'.  We overwrite the stacked operator with
15837                  * the result.  Then we redo this code to either push the new
15838                  * operator onto the stack or perform any higher precedence
15839                  * stacked operation */
15840                 only_to_avoid_leaks = av_pop(stack);
15841                 SvREFCNT_dec(only_to_avoid_leaks);
15842                 av_push(stack, rhs);
15843                 goto redo_curchar;
15844
15845             case '!':   /* Highest priority, right associative */
15846
15847                 /* If what's already at the top of the stack is another '!",
15848                  * they just cancel each other out */
15849                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15850                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15851                 {
15852                     only_to_avoid_leaks = av_pop(stack);
15853                     SvREFCNT_dec(only_to_avoid_leaks);
15854                 }
15855                 else { /* Otherwise, since it's right associative, just push
15856                           onto the stack */
15857                     av_push(stack, newSVuv(curchar));
15858                 }
15859                 break;
15860
15861             default:
15862                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15863                 vFAIL("Unexpected character");
15864
15865           handle_operand:
15866
15867             /* Here 'current' is the operand.  If something is already on the
15868              * stack, we have to check if it is a !.  But first, the code above
15869              * may have altered the stack in the time since we earlier set
15870              * 'top_index'.  */
15871
15872             top_index = av_tindex_skip_len_mg(stack);
15873             if (top_index - fence >= 0) {
15874                 /* If the top entry on the stack is an operator, it had better
15875                  * be a '!', otherwise the entry below the top operand should
15876                  * be an operator */
15877                 top_ptr = av_fetch(stack, top_index, FALSE);
15878                 assert(top_ptr);
15879                 if (IS_OPERATOR(*top_ptr)) {
15880
15881                     /* The only permissible operator at the top of the stack is
15882                      * '!', which is applied immediately to this operand. */
15883                     curchar = (char) SvUV(*top_ptr);
15884                     if (curchar != '!') {
15885                         SvREFCNT_dec(current);
15886                         vFAIL2("Unexpected binary operator '%c' with no "
15887                                 "preceding operand", curchar);
15888                     }
15889
15890                     _invlist_invert(current);
15891
15892                     only_to_avoid_leaks = av_pop(stack);
15893                     SvREFCNT_dec(only_to_avoid_leaks);
15894
15895                     /* And we redo with the inverted operand.  This allows
15896                      * handling multiple ! in a row */
15897                     goto handle_operand;
15898                 }
15899                           /* Single operand is ok only for the non-binary ')'
15900                            * operator */
15901                 else if ((top_index - fence == 0 && curchar != ')')
15902                          || (top_index - fence > 0
15903                              && (! (stacked_ptr = av_fetch(stack,
15904                                                            top_index - 1,
15905                                                            FALSE))
15906                                  || IS_OPERAND(*stacked_ptr))))
15907                 {
15908                     SvREFCNT_dec(current);
15909                     vFAIL("Operand with no preceding operator");
15910                 }
15911             }
15912
15913             /* Here there was nothing on the stack or the top element was
15914              * another operand.  Just add this new one */
15915             av_push(stack, current);
15916
15917         } /* End of switch on next parse token */
15918
15919         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15920     } /* End of loop parsing through the construct */
15921
15922   done:
15923     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
15924         vFAIL("Unmatched (");
15925     }
15926
15927     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
15928         || ((final = av_pop(stack)) == NULL)
15929         || ! IS_OPERAND(final)
15930         || SvTYPE(final) != SVt_INVLIST
15931         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
15932     {
15933       bad_syntax:
15934         SvREFCNT_dec(final);
15935         vFAIL("Incomplete expression within '(?[ ])'");
15936     }
15937
15938     /* Here, 'final' is the resultant inversion list from evaluating the
15939      * expression.  Return it if so requested */
15940     if (return_invlist) {
15941         *return_invlist = final;
15942         return END;
15943     }
15944
15945     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15946      * expecting a string of ranges and individual code points */
15947     invlist_iterinit(final);
15948     result_string = newSVpvs("");
15949     while (invlist_iternext(final, &start, &end)) {
15950         if (start == end) {
15951             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
15952         }
15953         else {
15954             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
15955                                                      start,          end);
15956         }
15957     }
15958
15959     /* About to generate an ANYOF (or similar) node from the inversion list we
15960      * have calculated */
15961     save_parse = RExC_parse;
15962     RExC_parse = SvPV(result_string, len);
15963     save_end = RExC_end;
15964     RExC_end = RExC_parse + len;
15965
15966     /* We turn off folding around the call, as the class we have constructed
15967      * already has all folding taken into consideration, and we don't want
15968      * regclass() to add to that */
15969     RExC_flags &= ~RXf_PMf_FOLD;
15970     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15971      * folds are allowed.  */
15972     node = regclass(pRExC_state, flagp,depth+1,
15973                     FALSE, /* means parse the whole char class */
15974                     FALSE, /* don't allow multi-char folds */
15975                     TRUE, /* silence non-portable warnings.  The above may very
15976                              well have generated non-portable code points, but
15977                              they're valid on this machine */
15978                     FALSE, /* similarly, no need for strict */
15979                     FALSE, /* Require return to be an ANYOF */
15980                     NULL,
15981                     NULL
15982                 );
15983     if (!node)
15984         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#" UVxf,
15985                     PTR2UV(flagp));
15986
15987     /* Fix up the node type if we are in locale.  (We have pretended we are
15988      * under /u for the purposes of regclass(), as this construct will only
15989      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15990      * as to cause any warnings about bad locales to be output in regexec.c),
15991      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15992      * reason we above forbid optimization into something other than an ANYOF
15993      * node is simply to minimize the number of code changes in regexec.c.
15994      * Otherwise we would have to create new EXACTish node types and deal with
15995      * them.  This decision could be revisited should this construct become
15996      * popular.
15997      *
15998      * (One might think we could look at the resulting ANYOF node and suppress
15999      * the flag if everything is above 255, as those would be UTF-8 only,
16000      * but this isn't true, as the components that led to that result could
16001      * have been locale-affected, and just happen to cancel each other out
16002      * under UTF-8 locales.) */
16003     if (in_locale) {
16004         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
16005
16006         assert(OP(node) == ANYOF);
16007
16008         OP(node) = ANYOFL;
16009         ANYOF_FLAGS(node)
16010                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
16011     }
16012
16013     if (save_fold) {
16014         RExC_flags |= RXf_PMf_FOLD;
16015     }
16016
16017     RExC_parse = save_parse + 1;
16018     RExC_end = save_end;
16019     SvREFCNT_dec_NN(final);
16020     SvREFCNT_dec_NN(result_string);
16021
16022     nextchar(pRExC_state);
16023     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
16024     return node;
16025 }
16026
16027 #ifdef ENABLE_REGEX_SETS_DEBUGGING
16028
16029 STATIC void
16030 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
16031                              AV * stack, const IV fence, AV * fence_stack)
16032 {   /* Dumps the stacks in handle_regex_sets() */
16033
16034     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
16035     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
16036     SSize_t i;
16037
16038     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
16039
16040     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
16041
16042     if (stack_top < 0) {
16043         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
16044     }
16045     else {
16046         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
16047         for (i = stack_top; i >= 0; i--) {
16048             SV ** element_ptr = av_fetch(stack, i, FALSE);
16049             if (! element_ptr) {
16050             }
16051
16052             if (IS_OPERATOR(*element_ptr)) {
16053                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
16054                                             (int) i, (int) SvIV(*element_ptr));
16055             }
16056             else {
16057                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
16058                 sv_dump(*element_ptr);
16059             }
16060         }
16061     }
16062
16063     if (fence_stack_top < 0) {
16064         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
16065     }
16066     else {
16067         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
16068         for (i = fence_stack_top; i >= 0; i--) {
16069             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
16070             if (! element_ptr) {
16071             }
16072
16073             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
16074                                             (int) i, (int) SvIV(*element_ptr));
16075         }
16076     }
16077 }
16078
16079 #endif
16080
16081 #undef IS_OPERATOR
16082 #undef IS_OPERAND
16083
16084 STATIC void
16085 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
16086 {
16087     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
16088      * innocent-looking character class, like /[ks]/i won't have to go out to
16089      * disk to find the possible matches.
16090      *
16091      * This should be called only for a Latin1-range code points, cp, which is
16092      * known to be involved in a simple fold with other code points above
16093      * Latin1.  It would give false results if /aa has been specified.
16094      * Multi-char folds are outside the scope of this, and must be handled
16095      * specially.
16096      *
16097      * XXX It would be better to generate these via regen, in case a new
16098      * version of the Unicode standard adds new mappings, though that is not
16099      * really likely, and may be caught by the default: case of the switch
16100      * below. */
16101
16102     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
16103
16104     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
16105
16106     switch (cp) {
16107         case 'k':
16108         case 'K':
16109           *invlist =
16110              add_cp_to_invlist(*invlist, KELVIN_SIGN);
16111             break;
16112         case 's':
16113         case 'S':
16114           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
16115             break;
16116         case MICRO_SIGN:
16117           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
16118           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
16119             break;
16120         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
16121         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
16122           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
16123             break;
16124         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
16125           *invlist = add_cp_to_invlist(*invlist,
16126                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
16127             break;
16128
16129 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
16130
16131         case LATIN_SMALL_LETTER_SHARP_S:
16132           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
16133             break;
16134
16135 #endif
16136
16137 #if    UNICODE_MAJOR_VERSION < 3                                        \
16138    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
16139
16140         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
16141          * U+0131.  */
16142         case 'i':
16143         case 'I':
16144           *invlist =
16145              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
16146 #   if UNICODE_DOT_DOT_VERSION == 1
16147           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
16148 #   endif
16149             break;
16150 #endif
16151
16152         default:
16153             /* Use deprecated warning to increase the chances of this being
16154              * output */
16155             if (PASS2) {
16156                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
16157             }
16158             break;
16159     }
16160 }
16161
16162 STATIC void
16163 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
16164 {
16165     /* If the final parameter is NULL, output the elements of the array given
16166      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
16167      * pushed onto it, (creating if necessary) */
16168
16169     SV * msg;
16170     const bool first_is_fatal =  ! return_posix_warnings
16171                                 && ckDEAD(packWARN(WARN_REGEXP));
16172
16173     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
16174
16175     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
16176         if (return_posix_warnings) {
16177             if (! *return_posix_warnings) { /* mortalize to not leak if
16178                                                warnings are fatal */
16179                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
16180             }
16181             av_push(*return_posix_warnings, msg);
16182         }
16183         else {
16184             if (first_is_fatal) {           /* Avoid leaking this */
16185                 av_undef(posix_warnings);   /* This isn't necessary if the
16186                                                array is mortal, but is a
16187                                                fail-safe */
16188                 (void) sv_2mortal(msg);
16189                 if (PASS2) {
16190                     SAVEFREESV(RExC_rx_sv);
16191                 }
16192             }
16193             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
16194             SvREFCNT_dec_NN(msg);
16195         }
16196     }
16197 }
16198
16199 STATIC AV *
16200 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
16201 {
16202     /* This adds the string scalar <multi_string> to the array
16203      * <multi_char_matches>.  <multi_string> is known to have exactly
16204      * <cp_count> code points in it.  This is used when constructing a
16205      * bracketed character class and we find something that needs to match more
16206      * than a single character.
16207      *
16208      * <multi_char_matches> is actually an array of arrays.  Each top-level
16209      * element is an array that contains all the strings known so far that are
16210      * the same length.  And that length (in number of code points) is the same
16211      * as the index of the top-level array.  Hence, the [2] element is an
16212      * array, each element thereof is a string containing TWO code points;
16213      * while element [3] is for strings of THREE characters, and so on.  Since
16214      * this is for multi-char strings there can never be a [0] nor [1] element.
16215      *
16216      * When we rewrite the character class below, we will do so such that the
16217      * longest strings are written first, so that it prefers the longest
16218      * matching strings first.  This is done even if it turns out that any
16219      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
16220      * Christiansen has agreed that this is ok.  This makes the test for the
16221      * ligature 'ffi' come before the test for 'ff', for example */
16222
16223     AV* this_array;
16224     AV** this_array_ptr;
16225
16226     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
16227
16228     if (! multi_char_matches) {
16229         multi_char_matches = newAV();
16230     }
16231
16232     if (av_exists(multi_char_matches, cp_count)) {
16233         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
16234         this_array = *this_array_ptr;
16235     }
16236     else {
16237         this_array = newAV();
16238         av_store(multi_char_matches, cp_count,
16239                  (SV*) this_array);
16240     }
16241     av_push(this_array, multi_string);
16242
16243     return multi_char_matches;
16244 }
16245
16246 /* The names of properties whose definitions are not known at compile time are
16247  * stored in this SV, after a constant heading.  So if the length has been
16248  * changed since initialization, then there is a run-time definition. */
16249 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
16250                                         (SvCUR(listsv) != initial_listsv_len)
16251
16252 /* There is a restricted set of white space characters that are legal when
16253  * ignoring white space in a bracketed character class.  This generates the
16254  * code to skip them.
16255  *
16256  * There is a line below that uses the same white space criteria but is outside
16257  * this macro.  Both here and there must use the same definition */
16258 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
16259     STMT_START {                                                        \
16260         if (do_skip) {                                                  \
16261             while (isBLANK_A(UCHARAT(p)))                               \
16262             {                                                           \
16263                 p++;                                                    \
16264             }                                                           \
16265         }                                                               \
16266     } STMT_END
16267
16268 STATIC regnode *
16269 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
16270                  const bool stop_at_1,  /* Just parse the next thing, don't
16271                                            look for a full character class */
16272                  bool allow_multi_folds,
16273                  const bool silence_non_portable,   /* Don't output warnings
16274                                                        about too large
16275                                                        characters */
16276                  const bool strict,
16277                  bool optimizable,                  /* ? Allow a non-ANYOF return
16278                                                        node */
16279                  SV** ret_invlist, /* Return an inversion list, not a node */
16280                  AV** return_posix_warnings
16281           )
16282 {
16283     /* parse a bracketed class specification.  Most of these will produce an
16284      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
16285      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
16286      * under /i with multi-character folds: it will be rewritten following the
16287      * paradigm of this example, where the <multi-fold>s are characters which
16288      * fold to multiple character sequences:
16289      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
16290      * gets effectively rewritten as:
16291      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
16292      * reg() gets called (recursively) on the rewritten version, and this
16293      * function will return what it constructs.  (Actually the <multi-fold>s
16294      * aren't physically removed from the [abcdefghi], it's just that they are
16295      * ignored in the recursion by means of a flag:
16296      * <RExC_in_multi_char_class>.)
16297      *
16298      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
16299      * characters, with the corresponding bit set if that character is in the
16300      * list.  For characters above this, a range list or swash is used.  There
16301      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
16302      * determinable at compile time
16303      *
16304      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
16305      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
16306      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
16307      */
16308
16309     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
16310     IV range = 0;
16311     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
16312     regnode *ret;
16313     STRLEN numlen;
16314     int namedclass = OOB_NAMEDCLASS;
16315     char *rangebegin = NULL;
16316     bool need_class = 0;
16317     SV *listsv = NULL;
16318     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
16319                                       than just initialized.  */
16320     SV* properties = NULL;    /* Code points that match \p{} \P{} */
16321     SV* posixes = NULL;     /* Code points that match classes like [:word:],
16322                                extended beyond the Latin1 range.  These have to
16323                                be kept separate from other code points for much
16324                                of this function because their handling  is
16325                                different under /i, and for most classes under
16326                                /d as well */
16327     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
16328                                separate for a while from the non-complemented
16329                                versions because of complications with /d
16330                                matching */
16331     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
16332                                   treated more simply than the general case,
16333                                   leading to less compilation and execution
16334                                   work */
16335     UV element_count = 0;   /* Number of distinct elements in the class.
16336                                Optimizations may be possible if this is tiny */
16337     AV * multi_char_matches = NULL; /* Code points that fold to more than one
16338                                        character; used under /i */
16339     UV n;
16340     char * stop_ptr = RExC_end;    /* where to stop parsing */
16341
16342     /* ignore unescaped whitespace? */
16343     const bool skip_white = cBOOL(   ret_invlist
16344                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
16345
16346     /* Unicode properties are stored in a swash; this holds the current one
16347      * being parsed.  If this swash is the only above-latin1 component of the
16348      * character class, an optimization is to pass it directly on to the
16349      * execution engine.  Otherwise, it is set to NULL to indicate that there
16350      * are other things in the class that have to be dealt with at execution
16351      * time */
16352     SV* swash = NULL;           /* Code points that match \p{} \P{} */
16353
16354     /* Set if a component of this character class is user-defined; just passed
16355      * on to the engine */
16356     bool has_user_defined_property = FALSE;
16357
16358     /* inversion list of code points this node matches only when the target
16359      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
16360      * /d) */
16361     SV* has_upper_latin1_only_utf8_matches = NULL;
16362
16363     /* Inversion list of code points this node matches regardless of things
16364      * like locale, folding, utf8ness of the target string */
16365     SV* cp_list = NULL;
16366
16367     /* Like cp_list, but code points on this list need to be checked for things
16368      * that fold to/from them under /i */
16369     SV* cp_foldable_list = NULL;
16370
16371     /* Like cp_list, but code points on this list are valid only when the
16372      * runtime locale is UTF-8 */
16373     SV* only_utf8_locale_list = NULL;
16374
16375     /* In a range, if one of the endpoints is non-character-set portable,
16376      * meaning that it hard-codes a code point that may mean a different
16377      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
16378      * mnemonic '\t' which each mean the same character no matter which
16379      * character set the platform is on. */
16380     unsigned int non_portable_endpoint = 0;
16381
16382     /* Is the range unicode? which means on a platform that isn't 1-1 native
16383      * to Unicode (i.e. non-ASCII), each code point in it should be considered
16384      * to be a Unicode value.  */
16385     bool unicode_range = FALSE;
16386     bool invert = FALSE;    /* Is this class to be complemented */
16387
16388     bool warn_super = ALWAYS_WARN_SUPER;
16389
16390     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
16391         case we need to change the emitted regop to an EXACT. */
16392     const char * orig_parse = RExC_parse;
16393     const SSize_t orig_size = RExC_size;
16394     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
16395
16396     /* This variable is used to mark where the end in the input is of something
16397      * that looks like a POSIX construct but isn't.  During the parse, when
16398      * something looks like it could be such a construct is encountered, it is
16399      * checked for being one, but not if we've already checked this area of the
16400      * input.  Only after this position is reached do we check again */
16401     char *not_posix_region_end = RExC_parse - 1;
16402
16403     AV* posix_warnings = NULL;
16404     const bool do_posix_warnings =     return_posix_warnings
16405                                    || (PASS2 && ckWARN(WARN_REGEXP));
16406
16407     GET_RE_DEBUG_FLAGS_DECL;
16408
16409     PERL_ARGS_ASSERT_REGCLASS;
16410 #ifndef DEBUGGING
16411     PERL_UNUSED_ARG(depth);
16412 #endif
16413
16414     DEBUG_PARSE("clas");
16415
16416 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
16417     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
16418                                    && UNICODE_DOT_DOT_VERSION == 0)
16419     allow_multi_folds = FALSE;
16420 #endif
16421
16422     /* Assume we are going to generate an ANYOF node. */
16423     ret = reganode(pRExC_state,
16424                    (LOC)
16425                     ? ANYOFL
16426                     : ANYOF,
16427                    0);
16428
16429     if (SIZE_ONLY) {
16430         RExC_size += ANYOF_SKIP;
16431         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
16432     }
16433     else {
16434         ANYOF_FLAGS(ret) = 0;
16435
16436         RExC_emit += ANYOF_SKIP;
16437         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
16438         initial_listsv_len = SvCUR(listsv);
16439         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
16440     }
16441
16442     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16443
16444     assert(RExC_parse <= RExC_end);
16445
16446     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
16447         RExC_parse++;
16448         invert = TRUE;
16449         allow_multi_folds = FALSE;
16450         MARK_NAUGHTY(1);
16451         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16452     }
16453
16454     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
16455     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
16456         int maybe_class = handle_possible_posix(pRExC_state,
16457                                                 RExC_parse,
16458                                                 &not_posix_region_end,
16459                                                 NULL,
16460                                                 TRUE /* checking only */);
16461         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
16462             SAVEFREESV(RExC_rx_sv);
16463             ckWARN4reg(not_posix_region_end,
16464                     "POSIX syntax [%c %c] belongs inside character classes%s",
16465                     *RExC_parse, *RExC_parse,
16466                     (maybe_class == OOB_NAMEDCLASS)
16467                     ? ((POSIXCC_NOTYET(*RExC_parse))
16468                         ? " (but this one isn't implemented)"
16469                         : " (but this one isn't fully valid)")
16470                     : ""
16471                     );
16472             (void)ReREFCNT_inc(RExC_rx_sv);
16473         }
16474     }
16475
16476     /* If the caller wants us to just parse a single element, accomplish this
16477      * by faking the loop ending condition */
16478     if (stop_at_1 && RExC_end > RExC_parse) {
16479         stop_ptr = RExC_parse + 1;
16480     }
16481
16482     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
16483     if (UCHARAT(RExC_parse) == ']')
16484         goto charclassloop;
16485
16486     while (1) {
16487
16488         if (   posix_warnings
16489             && av_tindex_skip_len_mg(posix_warnings) >= 0
16490             && RExC_parse > not_posix_region_end)
16491         {
16492             /* Warnings about posix class issues are considered tentative until
16493              * we are far enough along in the parse that we can no longer
16494              * change our mind, at which point we either output them or add
16495              * them, if it has so specified, to what gets returned to the
16496              * caller.  This is done each time through the loop so that a later
16497              * class won't zap them before they have been dealt with. */
16498             output_or_return_posix_warnings(pRExC_state, posix_warnings,
16499                                             return_posix_warnings);
16500         }
16501
16502         if  (RExC_parse >= stop_ptr) {
16503             break;
16504         }
16505
16506         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16507
16508         if  (UCHARAT(RExC_parse) == ']') {
16509             break;
16510         }
16511
16512       charclassloop:
16513
16514         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
16515         save_value = value;
16516         save_prevvalue = prevvalue;
16517
16518         if (!range) {
16519             rangebegin = RExC_parse;
16520             element_count++;
16521             non_portable_endpoint = 0;
16522         }
16523         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
16524             value = utf8n_to_uvchr((U8*)RExC_parse,
16525                                    RExC_end - RExC_parse,
16526                                    &numlen, UTF8_ALLOW_DEFAULT);
16527             RExC_parse += numlen;
16528         }
16529         else
16530             value = UCHARAT(RExC_parse++);
16531
16532         if (value == '[') {
16533             char * posix_class_end;
16534             namedclass = handle_possible_posix(pRExC_state,
16535                                                RExC_parse,
16536                                                &posix_class_end,
16537                                                do_posix_warnings ? &posix_warnings : NULL,
16538                                                FALSE    /* die if error */);
16539             if (namedclass > OOB_NAMEDCLASS) {
16540
16541                 /* If there was an earlier attempt to parse this particular
16542                  * posix class, and it failed, it was a false alarm, as this
16543                  * successful one proves */
16544                 if (   posix_warnings
16545                     && av_tindex_skip_len_mg(posix_warnings) >= 0
16546                     && not_posix_region_end >= RExC_parse
16547                     && not_posix_region_end <= posix_class_end)
16548                 {
16549                     av_undef(posix_warnings);
16550                 }
16551
16552                 RExC_parse = posix_class_end;
16553             }
16554             else if (namedclass == OOB_NAMEDCLASS) {
16555                 not_posix_region_end = posix_class_end;
16556             }
16557             else {
16558                 namedclass = OOB_NAMEDCLASS;
16559             }
16560         }
16561         else if (   RExC_parse - 1 > not_posix_region_end
16562                  && MAYBE_POSIXCC(value))
16563         {
16564             (void) handle_possible_posix(
16565                         pRExC_state,
16566                         RExC_parse - 1,  /* -1 because parse has already been
16567                                             advanced */
16568                         &not_posix_region_end,
16569                         do_posix_warnings ? &posix_warnings : NULL,
16570                         TRUE /* checking only */);
16571         }
16572         else if (  strict && ! skip_white
16573                  && (   _generic_isCC(value, _CC_VERTSPACE)
16574                      || is_VERTWS_cp_high(value)))
16575         {
16576             vFAIL("Literal vertical space in [] is illegal except under /x");
16577         }
16578         else if (value == '\\') {
16579             /* Is a backslash; get the code point of the char after it */
16580
16581             if (RExC_parse >= RExC_end) {
16582                 vFAIL("Unmatched [");
16583             }
16584
16585             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16586                 value = utf8n_to_uvchr((U8*)RExC_parse,
16587                                    RExC_end - RExC_parse,
16588                                    &numlen, UTF8_ALLOW_DEFAULT);
16589                 RExC_parse += numlen;
16590             }
16591             else
16592                 value = UCHARAT(RExC_parse++);
16593
16594             /* Some compilers cannot handle switching on 64-bit integer
16595              * values, therefore value cannot be an UV.  Yes, this will
16596              * be a problem later if we want switch on Unicode.
16597              * A similar issue a little bit later when switching on
16598              * namedclass. --jhi */
16599
16600             /* If the \ is escaping white space when white space is being
16601              * skipped, it means that that white space is wanted literally, and
16602              * is already in 'value'.  Otherwise, need to translate the escape
16603              * into what it signifies. */
16604             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16605
16606             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16607             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16608             case 's':   namedclass = ANYOF_SPACE;       break;
16609             case 'S':   namedclass = ANYOF_NSPACE;      break;
16610             case 'd':   namedclass = ANYOF_DIGIT;       break;
16611             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16612             case 'v':   namedclass = ANYOF_VERTWS;      break;
16613             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16614             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16615             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16616             case 'N':  /* Handle \N{NAME} in class */
16617                 {
16618                     const char * const backslash_N_beg = RExC_parse - 2;
16619                     int cp_count;
16620
16621                     if (! grok_bslash_N(pRExC_state,
16622                                         NULL,      /* No regnode */
16623                                         &value,    /* Yes single value */
16624                                         &cp_count, /* Multiple code pt count */
16625                                         flagp,
16626                                         strict,
16627                                         depth)
16628                     ) {
16629
16630                         if (*flagp & NEED_UTF8)
16631                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16632
16633                         RETURN_NULL_ON_RESTART_FLAGP(flagp);
16634
16635                         if (cp_count < 0) {
16636                             vFAIL("\\N in a character class must be a named character: \\N{...}");
16637                         }
16638                         else if (cp_count == 0) {
16639                             if (PASS2) {
16640                                 ckWARNreg(RExC_parse,
16641                                         "Ignoring zero length \\N{} in character class");
16642                             }
16643                         }
16644                         else { /* cp_count > 1 */
16645                             if (! RExC_in_multi_char_class) {
16646                                 if (invert || range || *RExC_parse == '-') {
16647                                     if (strict) {
16648                                         RExC_parse--;
16649                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
16650                                     }
16651                                     else if (PASS2) {
16652                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
16653                                     }
16654                                     break; /* <value> contains the first code
16655                                               point. Drop out of the switch to
16656                                               process it */
16657                                 }
16658                                 else {
16659                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
16660                                                  RExC_parse - backslash_N_beg);
16661                                     multi_char_matches
16662                                         = add_multi_match(multi_char_matches,
16663                                                           multi_char_N,
16664                                                           cp_count);
16665                                 }
16666                             }
16667                         } /* End of cp_count != 1 */
16668
16669                         /* This element should not be processed further in this
16670                          * class */
16671                         element_count--;
16672                         value = save_value;
16673                         prevvalue = save_prevvalue;
16674                         continue;   /* Back to top of loop to get next char */
16675                     }
16676
16677                     /* Here, is a single code point, and <value> contains it */
16678                     unicode_range = TRUE;   /* \N{} are Unicode */
16679                 }
16680                 break;
16681             case 'p':
16682             case 'P':
16683                 {
16684                 char *e;
16685
16686                 /* We will handle any undefined properties ourselves */
16687                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
16688                                        /* And we actually would prefer to get
16689                                         * the straight inversion list of the
16690                                         * swash, since we will be accessing it
16691                                         * anyway, to save a little time */
16692                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
16693
16694                 if (RExC_parse >= RExC_end)
16695                     vFAIL2("Empty \\%c", (U8)value);
16696                 if (*RExC_parse == '{') {
16697                     const U8 c = (U8)value;
16698                     e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
16699                     if (!e) {
16700                         RExC_parse++;
16701                         vFAIL2("Missing right brace on \\%c{}", c);
16702                     }
16703
16704                     RExC_parse++;
16705                     while (isSPACE(*RExC_parse)) {
16706                          RExC_parse++;
16707                     }
16708
16709                     if (UCHARAT(RExC_parse) == '^') {
16710
16711                         /* toggle.  (The rhs xor gets the single bit that
16712                          * differs between P and p; the other xor inverts just
16713                          * that bit) */
16714                         value ^= 'P' ^ 'p';
16715
16716                         RExC_parse++;
16717                         while (isSPACE(*RExC_parse)) {
16718                             RExC_parse++;
16719                         }
16720                     }
16721
16722                     if (e == RExC_parse)
16723                         vFAIL2("Empty \\%c{}", c);
16724
16725                     n = e - RExC_parse;
16726                     while (isSPACE(*(RExC_parse + n - 1)))
16727                         n--;
16728                 }   /* The \p isn't immediately followed by a '{' */
16729                 else if (! isALPHA(*RExC_parse)) {
16730                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16731                     vFAIL2("Character following \\%c must be '{' or a "
16732                            "single-character Unicode property name",
16733                            (U8) value);
16734                 }
16735                 else {
16736                     e = RExC_parse;
16737                     n = 1;
16738                 }
16739                 if (!SIZE_ONLY) {
16740                     SV* invlist;
16741                     char* name;
16742                     char* base_name;    /* name after any packages are stripped */
16743                     char* lookup_name = NULL;
16744                     const char * const colon_colon = "::";
16745
16746                     /* Try to get the definition of the property into
16747                      * <invlist>.  If /i is in effect, the effective property
16748                      * will have its name be <__NAME_i>.  The design is
16749                      * discussed in commit
16750                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
16751                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
16752                     SAVEFREEPV(name);
16753                     if (FOLD) {
16754                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
16755
16756                         /* The function call just below that uses this can fail
16757                          * to return, leaking memory if we don't do this */
16758                         SAVEFREEPV(lookup_name);
16759                     }
16760
16761                     /* Look up the property name, and get its swash and
16762                      * inversion list, if the property is found  */
16763                     SvREFCNT_dec(swash); /* Free any left-overs */
16764                     swash = _core_swash_init("utf8",
16765                                              (lookup_name)
16766                                               ? lookup_name
16767                                               : name,
16768                                              &PL_sv_undef,
16769                                              1, /* binary */
16770                                              0, /* not tr/// */
16771                                              NULL, /* No inversion list */
16772                                              &swash_init_flags
16773                                             );
16774                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
16775                         HV* curpkg = (IN_PERL_COMPILETIME)
16776                                       ? PL_curstash
16777                                       : CopSTASH(PL_curcop);
16778                         UV final_n = n;
16779                         bool has_pkg;
16780
16781                         if (swash) {    /* Got a swash but no inversion list.
16782                                            Something is likely wrong that will
16783                                            be sorted-out later */
16784                             SvREFCNT_dec_NN(swash);
16785                             swash = NULL;
16786                         }
16787
16788                         /* Here didn't find it.  It could be a an error (like a
16789                          * typo) in specifying a Unicode property, or it could
16790                          * be a user-defined property that will be available at
16791                          * run-time.  The names of these must begin with 'In'
16792                          * or 'Is' (after any packages are stripped off).  So
16793                          * if not one of those, or if we accept only
16794                          * compile-time properties, is an error; otherwise add
16795                          * it to the list for run-time look up. */
16796                         if ((base_name = rninstr(name, name + n,
16797                                                  colon_colon, colon_colon + 2)))
16798                         { /* Has ::.  We know this must be a user-defined
16799                              property */
16800                             base_name += 2;
16801                             final_n -= base_name - name;
16802                             has_pkg = TRUE;
16803                         }
16804                         else {
16805                             base_name = name;
16806                             has_pkg = FALSE;
16807                         }
16808
16809                         if (   final_n < 3
16810                             || base_name[0] != 'I'
16811                             || (base_name[1] != 's' && base_name[1] != 'n')
16812                             || ret_invlist)
16813                         {
16814                             const char * const msg
16815                                 = (has_pkg)
16816                                   ? "Illegal user-defined property name"
16817                                   : "Can't find Unicode property definition";
16818                             RExC_parse = e + 1;
16819
16820                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16821                             vFAIL3utf8f("%s \"%" UTF8f "\"",
16822                                 msg, UTF8fARG(UTF, n, name));
16823                         }
16824
16825                         /* If the property name doesn't already have a package
16826                          * name, add the current one to it so that it can be
16827                          * referred to outside it. [perl #121777] */
16828                         if (! has_pkg && curpkg) {
16829                             char* pkgname = HvNAME(curpkg);
16830                             if (memNEs(pkgname, HvNAMELEN(curpkg), "main")) {
16831                                 char* full_name = Perl_form(aTHX_
16832                                                             "%s::%s",
16833                                                             pkgname,
16834                                                             name);
16835                                 n = strlen(full_name);
16836                                 name = savepvn(full_name, n);
16837                                 SAVEFREEPV(name);
16838                             }
16839                         }
16840                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
16841                                         (value == 'p' ? '+' : '!'),
16842                                         (FOLD) ? "__" : "",
16843                                         UTF8fARG(UTF, n, name),
16844                                         (FOLD) ? "_i" : "");
16845                         has_user_defined_property = TRUE;
16846                         optimizable = FALSE;    /* Will have to leave this an
16847                                                    ANYOF node */
16848
16849                         /* We don't know yet what this matches, so have to flag
16850                          * it */
16851                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16852                     }
16853                     else {
16854
16855                         /* Here, did get the swash and its inversion list.  If
16856                          * the swash is from a user-defined property, then this
16857                          * whole character class should be regarded as such */
16858                         if (swash_init_flags
16859                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16860                         {
16861                             has_user_defined_property = TRUE;
16862                         }
16863                         else if
16864                             /* We warn on matching an above-Unicode code point
16865                              * if the match would return true, except don't
16866                              * warn for \p{All}, which has exactly one element
16867                              * = 0 */
16868                             (_invlist_contains_cp(invlist, 0x110000)
16869                                 && (! (_invlist_len(invlist) == 1
16870                                        && *invlist_array(invlist) == 0)))
16871                         {
16872                             warn_super = TRUE;
16873                         }
16874
16875
16876                         /* Invert if asking for the complement */
16877                         if (value == 'P') {
16878                             _invlist_union_complement_2nd(properties,
16879                                                           invlist,
16880                                                           &properties);
16881
16882                             /* The swash can't be used as-is, because we've
16883                              * inverted things; delay removing it to here after
16884                              * have copied its invlist above */
16885                             SvREFCNT_dec_NN(swash);
16886                             swash = NULL;
16887                         }
16888                         else {
16889                             _invlist_union(properties, invlist, &properties);
16890                         }
16891                     }
16892                 }
16893                 RExC_parse = e + 1;
16894                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16895                                                 named */
16896
16897                 /* \p means they want Unicode semantics */
16898                 REQUIRE_UNI_RULES(flagp, NULL);
16899                 }
16900                 break;
16901             case 'n':   value = '\n';                   break;
16902             case 'r':   value = '\r';                   break;
16903             case 't':   value = '\t';                   break;
16904             case 'f':   value = '\f';                   break;
16905             case 'b':   value = '\b';                   break;
16906             case 'e':   value = ESC_NATIVE;             break;
16907             case 'a':   value = '\a';                   break;
16908             case 'o':
16909                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16910                 {
16911                     const char* error_msg;
16912                     bool valid = grok_bslash_o(&RExC_parse,
16913                                                RExC_end,
16914                                                &value,
16915                                                &error_msg,
16916                                                PASS2,   /* warnings only in
16917                                                            pass 2 */
16918                                                strict,
16919                                                silence_non_portable,
16920                                                UTF);
16921                     if (! valid) {
16922                         vFAIL(error_msg);
16923                     }
16924                 }
16925                 non_portable_endpoint++;
16926                 break;
16927             case 'x':
16928                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16929                 {
16930                     const char* error_msg;
16931                     bool valid = grok_bslash_x(&RExC_parse,
16932                                                RExC_end,
16933                                                &value,
16934                                                &error_msg,
16935                                                PASS2, /* Output warnings */
16936                                                strict,
16937                                                silence_non_portable,
16938                                                UTF);
16939                     if (! valid) {
16940                         vFAIL(error_msg);
16941                     }
16942                 }
16943                 non_portable_endpoint++;
16944                 break;
16945             case 'c':
16946                 value = grok_bslash_c(*RExC_parse++, PASS2);
16947                 non_portable_endpoint++;
16948                 break;
16949             case '0': case '1': case '2': case '3': case '4':
16950             case '5': case '6': case '7':
16951                 {
16952                     /* Take 1-3 octal digits */
16953                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16954                     numlen = (strict) ? 4 : 3;
16955                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16956                     RExC_parse += numlen;
16957                     if (numlen != 3) {
16958                         if (strict) {
16959                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16960                             vFAIL("Need exactly 3 octal digits");
16961                         }
16962                         else if (! SIZE_ONLY /* like \08, \178 */
16963                                  && numlen < 3
16964                                  && RExC_parse < RExC_end
16965                                  && isDIGIT(*RExC_parse)
16966                                  && ckWARN(WARN_REGEXP))
16967                         {
16968                             SAVEFREESV(RExC_rx_sv);
16969                             reg_warn_non_literal_string(
16970                                  RExC_parse + 1,
16971                                  form_short_octal_warning(RExC_parse, numlen));
16972                             (void)ReREFCNT_inc(RExC_rx_sv);
16973                         }
16974                     }
16975                     non_portable_endpoint++;
16976                     break;
16977                 }
16978             default:
16979                 /* Allow \_ to not give an error */
16980                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16981                     if (strict) {
16982                         vFAIL2("Unrecognized escape \\%c in character class",
16983                                (int)value);
16984                     }
16985                     else {
16986                         SAVEFREESV(RExC_rx_sv);
16987                         ckWARN2reg(RExC_parse,
16988                             "Unrecognized escape \\%c in character class passed through",
16989                             (int)value);
16990                         (void)ReREFCNT_inc(RExC_rx_sv);
16991                     }
16992                 }
16993                 break;
16994             }   /* End of switch on char following backslash */
16995         } /* end of handling backslash escape sequences */
16996
16997         /* Here, we have the current token in 'value' */
16998
16999         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
17000             U8 classnum;
17001
17002             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
17003              * literal, as is the character that began the false range, i.e.
17004              * the 'a' in the examples */
17005             if (range) {
17006                 if (!SIZE_ONLY) {
17007                     const int w = (RExC_parse >= rangebegin)
17008                                   ? RExC_parse - rangebegin
17009                                   : 0;
17010                     if (strict) {
17011                         vFAIL2utf8f(
17012                             "False [] range \"%" UTF8f "\"",
17013                             UTF8fARG(UTF, w, rangebegin));
17014                     }
17015                     else {
17016                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
17017                         ckWARN2reg(RExC_parse,
17018                             "False [] range \"%" UTF8f "\"",
17019                             UTF8fARG(UTF, w, rangebegin));
17020                         (void)ReREFCNT_inc(RExC_rx_sv);
17021                         cp_list = add_cp_to_invlist(cp_list, '-');
17022                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
17023                                                              prevvalue);
17024                     }
17025                 }
17026
17027                 range = 0; /* this was not a true range */
17028                 element_count += 2; /* So counts for three values */
17029             }
17030
17031             classnum = namedclass_to_classnum(namedclass);
17032
17033             if (LOC && namedclass < ANYOF_POSIXL_MAX
17034 #ifndef HAS_ISASCII
17035                 && classnum != _CC_ASCII
17036 #endif
17037             ) {
17038                 /* What the Posix classes (like \w, [:space:]) match in locale
17039                  * isn't knowable under locale until actual match time.  Room
17040                  * must be reserved (one time per outer bracketed class) to
17041                  * store such classes.  The space will contain a bit for each
17042                  * named class that is to be matched against.  This isn't
17043                  * needed for \p{} and pseudo-classes, as they are not affected
17044                  * by locale, and hence are dealt with separately */
17045                 if (! need_class) {
17046                     need_class = 1;
17047                     if (SIZE_ONLY) {
17048                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
17049                     }
17050                     else {
17051                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
17052                     }
17053                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
17054                     ANYOF_POSIXL_ZERO(ret);
17055
17056                     /* We can't change this into some other type of node
17057                      * (unless this is the only element, in which case there
17058                      * are nodes that mean exactly this) as has runtime
17059                      * dependencies */
17060                     optimizable = FALSE;
17061                 }
17062
17063                 /* Coverity thinks it is possible for this to be negative; both
17064                  * jhi and khw think it's not, but be safer */
17065                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
17066                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
17067
17068                 /* See if it already matches the complement of this POSIX
17069                  * class */
17070                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
17071                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
17072                                                             ? -1
17073                                                             : 1)))
17074                 {
17075                     posixl_matches_all = TRUE;
17076                     break;  /* No need to continue.  Since it matches both
17077                                e.g., \w and \W, it matches everything, and the
17078                                bracketed class can be optimized into qr/./s */
17079                 }
17080
17081                 /* Add this class to those that should be checked at runtime */
17082                 ANYOF_POSIXL_SET(ret, namedclass);
17083
17084                 /* The above-Latin1 characters are not subject to locale rules.
17085                  * Just add them, in the second pass, to the
17086                  * unconditionally-matched list */
17087                 if (! SIZE_ONLY) {
17088                     SV* scratch_list = NULL;
17089
17090                     /* Get the list of the above-Latin1 code points this
17091                      * matches */
17092                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
17093                                           PL_XPosix_ptrs[classnum],
17094
17095                                           /* Odd numbers are complements, like
17096                                            * NDIGIT, NASCII, ... */
17097                                           namedclass % 2 != 0,
17098                                           &scratch_list);
17099                     /* Checking if 'cp_list' is NULL first saves an extra
17100                      * clone.  Its reference count will be decremented at the
17101                      * next union, etc, or if this is the only instance, at the
17102                      * end of the routine */
17103                     if (! cp_list) {
17104                         cp_list = scratch_list;
17105                     }
17106                     else {
17107                         _invlist_union(cp_list, scratch_list, &cp_list);
17108                         SvREFCNT_dec_NN(scratch_list);
17109                     }
17110                     continue;   /* Go get next character */
17111                 }
17112             }
17113             else if (! SIZE_ONLY) {
17114
17115                 /* Here, not in pass1 (in that pass we skip calculating the
17116                  * contents of this class), and is not /l, or is a POSIX class
17117                  * for which /l doesn't matter (or is a Unicode property, which
17118                  * is skipped here). */
17119                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
17120                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
17121
17122                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
17123                          * nor /l make a difference in what these match,
17124                          * therefore we just add what they match to cp_list. */
17125                         if (classnum != _CC_VERTSPACE) {
17126                             assert(   namedclass == ANYOF_HORIZWS
17127                                    || namedclass == ANYOF_NHORIZWS);
17128
17129                             /* It turns out that \h is just a synonym for
17130                              * XPosixBlank */
17131                             classnum = _CC_BLANK;
17132                         }
17133
17134                         _invlist_union_maybe_complement_2nd(
17135                                 cp_list,
17136                                 PL_XPosix_ptrs[classnum],
17137                                 namedclass % 2 != 0,    /* Complement if odd
17138                                                           (NHORIZWS, NVERTWS)
17139                                                         */
17140                                 &cp_list);
17141                     }
17142                 }
17143                 else if (  UNI_SEMANTICS
17144                         || classnum == _CC_ASCII
17145                         || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
17146                                                   || classnum == _CC_XDIGIT)))
17147                 {
17148                     /* We usually have to worry about /d and /a affecting what
17149                      * POSIX classes match, with special code needed for /d
17150                      * because we won't know until runtime what all matches.
17151                      * But there is no extra work needed under /u, and
17152                      * [:ascii:] is unaffected by /a and /d; and :digit: and
17153                      * :xdigit: don't have runtime differences under /d.  So we
17154                      * can special case these, and avoid some extra work below,
17155                      * and at runtime. */
17156                     _invlist_union_maybe_complement_2nd(
17157                                                      simple_posixes,
17158                                                      PL_XPosix_ptrs[classnum],
17159                                                      namedclass % 2 != 0,
17160                                                      &simple_posixes);
17161                 }
17162                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
17163                            complement and use nposixes */
17164                     SV** posixes_ptr = namedclass % 2 == 0
17165                                        ? &posixes
17166                                        : &nposixes;
17167                     _invlist_union_maybe_complement_2nd(
17168                                                      *posixes_ptr,
17169                                                      PL_XPosix_ptrs[classnum],
17170                                                      namedclass % 2 != 0,
17171                                                      posixes_ptr);
17172                 }
17173             }
17174         } /* end of namedclass \blah */
17175
17176         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
17177
17178         /* If 'range' is set, 'value' is the ending of a range--check its
17179          * validity.  (If value isn't a single code point in the case of a
17180          * range, we should have figured that out above in the code that
17181          * catches false ranges).  Later, we will handle each individual code
17182          * point in the range.  If 'range' isn't set, this could be the
17183          * beginning of a range, so check for that by looking ahead to see if
17184          * the next real character to be processed is the range indicator--the
17185          * minus sign */
17186
17187         if (range) {
17188 #ifdef EBCDIC
17189             /* For unicode ranges, we have to test that the Unicode as opposed
17190              * to the native values are not decreasing.  (Above 255, there is
17191              * no difference between native and Unicode) */
17192             if (unicode_range && prevvalue < 255 && value < 255) {
17193                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
17194                     goto backwards_range;
17195                 }
17196             }
17197             else
17198 #endif
17199             if (prevvalue > value) /* b-a */ {
17200                 int w;
17201 #ifdef EBCDIC
17202               backwards_range:
17203 #endif
17204                 w = RExC_parse - rangebegin;
17205                 vFAIL2utf8f(
17206                     "Invalid [] range \"%" UTF8f "\"",
17207                     UTF8fARG(UTF, w, rangebegin));
17208                 NOT_REACHED; /* NOTREACHED */
17209             }
17210         }
17211         else {
17212             prevvalue = value; /* save the beginning of the potential range */
17213             if (! stop_at_1     /* Can't be a range if parsing just one thing */
17214                 && *RExC_parse == '-')
17215             {
17216                 char* next_char_ptr = RExC_parse + 1;
17217
17218                 /* Get the next real char after the '-' */
17219                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
17220
17221                 /* If the '-' is at the end of the class (just before the ']',
17222                  * it is a literal minus; otherwise it is a range */
17223                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
17224                     RExC_parse = next_char_ptr;
17225
17226                     /* a bad range like \w-, [:word:]- ? */
17227                     if (namedclass > OOB_NAMEDCLASS) {
17228                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
17229                             const int w = RExC_parse >= rangebegin
17230                                           ?  RExC_parse - rangebegin
17231                                           : 0;
17232                             if (strict) {
17233                                 vFAIL4("False [] range \"%*.*s\"",
17234                                     w, w, rangebegin);
17235                             }
17236                             else if (PASS2) {
17237                                 vWARN4(RExC_parse,
17238                                     "False [] range \"%*.*s\"",
17239                                     w, w, rangebegin);
17240                             }
17241                         }
17242                         if (!SIZE_ONLY) {
17243                             cp_list = add_cp_to_invlist(cp_list, '-');
17244                         }
17245                         element_count++;
17246                     } else
17247                         range = 1;      /* yeah, it's a range! */
17248                     continue;   /* but do it the next time */
17249                 }
17250             }
17251         }
17252
17253         if (namedclass > OOB_NAMEDCLASS) {
17254             continue;
17255         }
17256
17257         /* Here, we have a single value this time through the loop, and
17258          * <prevvalue> is the beginning of the range, if any; or <value> if
17259          * not. */
17260
17261         /* non-Latin1 code point implies unicode semantics.  Must be set in
17262          * pass1 so is there for the whole of pass 2 */
17263         if (value > 255) {
17264             REQUIRE_UNI_RULES(flagp, NULL);
17265         }
17266
17267         /* Ready to process either the single value, or the completed range.
17268          * For single-valued non-inverted ranges, we consider the possibility
17269          * of multi-char folds.  (We made a conscious decision to not do this
17270          * for the other cases because it can often lead to non-intuitive
17271          * results.  For example, you have the peculiar case that:
17272          *  "s s" =~ /^[^\xDF]+$/i => Y
17273          *  "ss"  =~ /^[^\xDF]+$/i => N
17274          *
17275          * See [perl #89750] */
17276         if (FOLD && allow_multi_folds && value == prevvalue) {
17277             if (value == LATIN_SMALL_LETTER_SHARP_S
17278                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
17279                                                         value)))
17280             {
17281                 /* Here <value> is indeed a multi-char fold.  Get what it is */
17282
17283                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17284                 STRLEN foldlen;
17285
17286                 UV folded = _to_uni_fold_flags(
17287                                 value,
17288                                 foldbuf,
17289                                 &foldlen,
17290                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
17291                                                    ? FOLD_FLAGS_NOMIX_ASCII
17292                                                    : 0)
17293                                 );
17294
17295                 /* Here, <folded> should be the first character of the
17296                  * multi-char fold of <value>, with <foldbuf> containing the
17297                  * whole thing.  But, if this fold is not allowed (because of
17298                  * the flags), <fold> will be the same as <value>, and should
17299                  * be processed like any other character, so skip the special
17300                  * handling */
17301                 if (folded != value) {
17302
17303                     /* Skip if we are recursed, currently parsing the class
17304                      * again.  Otherwise add this character to the list of
17305                      * multi-char folds. */
17306                     if (! RExC_in_multi_char_class) {
17307                         STRLEN cp_count = utf8_length(foldbuf,
17308                                                       foldbuf + foldlen);
17309                         SV* multi_fold = sv_2mortal(newSVpvs(""));
17310
17311                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
17312
17313                         multi_char_matches
17314                                         = add_multi_match(multi_char_matches,
17315                                                           multi_fold,
17316                                                           cp_count);
17317
17318                     }
17319
17320                     /* This element should not be processed further in this
17321                      * class */
17322                     element_count--;
17323                     value = save_value;
17324                     prevvalue = save_prevvalue;
17325                     continue;
17326                 }
17327             }
17328         }
17329
17330         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
17331             if (range) {
17332
17333                 /* If the range starts above 255, everything is portable and
17334                  * likely to be so for any forseeable character set, so don't
17335                  * warn. */
17336                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
17337                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
17338                 }
17339                 else if (prevvalue != value) {
17340
17341                     /* Under strict, ranges that stop and/or end in an ASCII
17342                      * printable should have each end point be a portable value
17343                      * for it (preferably like 'A', but we don't warn if it is
17344                      * a (portable) Unicode name or code point), and the range
17345                      * must be be all digits or all letters of the same case.
17346                      * Otherwise, the range is non-portable and unclear as to
17347                      * what it contains */
17348                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
17349                         && (          non_portable_endpoint
17350                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
17351                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
17352                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
17353                     ))) {
17354                         vWARN(RExC_parse, "Ranges of ASCII printables should"
17355                                           " be some subset of \"0-9\","
17356                                           " \"A-Z\", or \"a-z\"");
17357                     }
17358                     else if (prevvalue >= FIRST_NON_ASCII_DECIMAL_DIGIT) {
17359                         SSize_t index_start;
17360                         SSize_t index_final;
17361
17362                         /* But the nature of Unicode and languages mean we
17363                          * can't do the same checks for above-ASCII ranges,
17364                          * except in the case of digit ones.  These should
17365                          * contain only digits from the same group of 10.  The
17366                          * ASCII case is handled just above.  Hence here, the
17367                          * range could be a range of digits.  First some
17368                          * unlikely special cases.  Grandfather in that a range
17369                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
17370                          * if its starting value is one of the 10 digits prior
17371                          * to it.  This is because it is an alternate way of
17372                          * writing 19D1, and some people may expect it to be in
17373                          * that group.  But it is bad, because it won't give
17374                          * the expected results.  In Unicode 5.2 it was
17375                          * considered to be in that group (of 11, hence), but
17376                          * this was fixed in the next version */
17377
17378                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
17379                             goto warn_bad_digit_range;
17380                         }
17381                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
17382                                           &&     value <= 0x1D7FF))
17383                         {
17384                             /* This is the only other case currently in Unicode
17385                              * where the algorithm below fails.  The code
17386                              * points just above are the end points of a single
17387                              * range containing only decimal digits.  It is 5
17388                              * different series of 0-9.  All other ranges of
17389                              * digits currently in Unicode are just a single
17390                              * series.  (And mktables will notify us if a later
17391                              * Unicode version breaks this.)
17392                              *
17393                              * If the range being checked is at most 9 long,
17394                              * and the digit values represented are in
17395                              * numerical order, they are from the same series.
17396                              * */
17397                             if (         value - prevvalue > 9
17398                                 ||    (((    value - 0x1D7CE) % 10)
17399                                      <= (prevvalue - 0x1D7CE) % 10))
17400                             {
17401                                 goto warn_bad_digit_range;
17402                             }
17403                         }
17404                         else {
17405
17406                             /* For all other ranges of digits in Unicode, the
17407                              * algorithm is just to check if both end points
17408                              * are in the same series, which is the same range.
17409                              * */
17410                             index_start = _invlist_search(
17411                                                     PL_XPosix_ptrs[_CC_DIGIT],
17412                                                     prevvalue);
17413
17414                             /* Warn if the range starts and ends with a digit,
17415                              * and they are not in the same group of 10. */
17416                             if (   index_start >= 0
17417                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
17418                                 && (index_final =
17419                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
17420                                                     value)) != index_start
17421                                 && index_final >= 0
17422                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
17423                             {
17424                               warn_bad_digit_range:
17425                                 vWARN(RExC_parse, "Ranges of digits should be"
17426                                                   " from the same group of"
17427                                                   " 10");
17428                             }
17429                         }
17430                     }
17431                 }
17432             }
17433             if ((! range || prevvalue == value) && non_portable_endpoint) {
17434                 if (isPRINT_A(value)) {
17435                     char literal[3];
17436                     unsigned d = 0;
17437                     if (isBACKSLASHED_PUNCT(value)) {
17438                         literal[d++] = '\\';
17439                     }
17440                     literal[d++] = (char) value;
17441                     literal[d++] = '\0';
17442
17443                     vWARN4(RExC_parse,
17444                            "\"%.*s\" is more clearly written simply as \"%s\"",
17445                            (int) (RExC_parse - rangebegin),
17446                            rangebegin,
17447                            literal
17448                         );
17449                 }
17450                 else if isMNEMONIC_CNTRL(value) {
17451                     vWARN4(RExC_parse,
17452                            "\"%.*s\" is more clearly written simply as \"%s\"",
17453                            (int) (RExC_parse - rangebegin),
17454                            rangebegin,
17455                            cntrl_to_mnemonic((U8) value)
17456                         );
17457                 }
17458             }
17459         }
17460
17461         /* Deal with this element of the class */
17462         if (! SIZE_ONLY) {
17463
17464 #ifndef EBCDIC
17465             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17466                                                      prevvalue, value);
17467 #else
17468             /* On non-ASCII platforms, for ranges that span all of 0..255, and
17469              * ones that don't require special handling, we can just add the
17470              * range like we do for ASCII platforms */
17471             if ((UNLIKELY(prevvalue == 0) && value >= 255)
17472                 || ! (prevvalue < 256
17473                       && (unicode_range
17474                           || (! non_portable_endpoint
17475                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
17476                                   || (isUPPER_A(prevvalue)
17477                                       && isUPPER_A(value)))))))
17478             {
17479                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17480                                                          prevvalue, value);
17481             }
17482             else {
17483                 /* Here, requires special handling.  This can be because it is
17484                  * a range whose code points are considered to be Unicode, and
17485                  * so must be individually translated into native, or because
17486                  * its a subrange of 'A-Z' or 'a-z' which each aren't
17487                  * contiguous in EBCDIC, but we have defined them to include
17488                  * only the "expected" upper or lower case ASCII alphabetics.
17489                  * Subranges above 255 are the same in native and Unicode, so
17490                  * can be added as a range */
17491                 U8 start = NATIVE_TO_LATIN1(prevvalue);
17492                 unsigned j;
17493                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
17494                 for (j = start; j <= end; j++) {
17495                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
17496                 }
17497                 if (value > 255) {
17498                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17499                                                              256, value);
17500                 }
17501             }
17502 #endif
17503         }
17504
17505         range = 0; /* this range (if it was one) is done now */
17506     } /* End of loop through all the text within the brackets */
17507
17508
17509     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
17510         output_or_return_posix_warnings(pRExC_state, posix_warnings,
17511                                         return_posix_warnings);
17512     }
17513
17514     /* If anything in the class expands to more than one character, we have to
17515      * deal with them by building up a substitute parse string, and recursively
17516      * calling reg() on it, instead of proceeding */
17517     if (multi_char_matches) {
17518         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
17519         I32 cp_count;
17520         STRLEN len;
17521         char *save_end = RExC_end;
17522         char *save_parse = RExC_parse;
17523         char *save_start = RExC_start;
17524         STRLEN prefix_end = 0;      /* We copy the character class after a
17525                                        prefix supplied here.  This is the size
17526                                        + 1 of that prefix */
17527         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
17528                                        a "|" */
17529         I32 reg_flags;
17530
17531         assert(! invert);
17532         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
17533
17534 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
17535            because too confusing */
17536         if (invert) {
17537             sv_catpv(substitute_parse, "(?:");
17538         }
17539 #endif
17540
17541         /* Look at the longest folds first */
17542         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
17543                         cp_count > 0;
17544                         cp_count--)
17545         {
17546
17547             if (av_exists(multi_char_matches, cp_count)) {
17548                 AV** this_array_ptr;
17549                 SV* this_sequence;
17550
17551                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
17552                                                  cp_count, FALSE);
17553                 while ((this_sequence = av_pop(*this_array_ptr)) !=
17554                                                                 &PL_sv_undef)
17555                 {
17556                     if (! first_time) {
17557                         sv_catpv(substitute_parse, "|");
17558                     }
17559                     first_time = FALSE;
17560
17561                     sv_catpv(substitute_parse, SvPVX(this_sequence));
17562                 }
17563             }
17564         }
17565
17566         /* If the character class contains anything else besides these
17567          * multi-character folds, have to include it in recursive parsing */
17568         if (element_count) {
17569             sv_catpv(substitute_parse, "|[");
17570             prefix_end = SvCUR(substitute_parse);
17571             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17572
17573             /* Put in a closing ']' only if not going off the end, as otherwise
17574              * we are adding something that really isn't there */
17575             if (RExC_parse < RExC_end) {
17576                 sv_catpv(substitute_parse, "]");
17577             }
17578         }
17579
17580         sv_catpv(substitute_parse, ")");
17581 #if 0
17582         if (invert) {
17583             /* This is a way to get the parse to skip forward a whole named
17584              * sequence instead of matching the 2nd character when it fails the
17585              * first */
17586             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17587         }
17588 #endif
17589
17590         /* Set up the data structure so that any errors will be properly
17591          * reported.  See the comments at the definition of
17592          * REPORT_LOCATION_ARGS for details */
17593         RExC_precomp_adj = orig_parse - RExC_precomp;
17594         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
17595         RExC_adjusted_start = RExC_start + prefix_end;
17596         RExC_end = RExC_parse + len;
17597         RExC_in_multi_char_class = 1;
17598         RExC_emit = (regnode *)orig_emit;
17599
17600         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17601
17602         *flagp |= reg_flags & (HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
17603
17604         /* And restore so can parse the rest of the pattern */
17605         RExC_parse = save_parse;
17606         RExC_start = RExC_adjusted_start = save_start;
17607         RExC_precomp_adj = 0;
17608         RExC_end = save_end;
17609         RExC_in_multi_char_class = 0;
17610         SvREFCNT_dec_NN(multi_char_matches);
17611         return ret;
17612     }
17613
17614     /* Here, we've gone through the entire class and dealt with multi-char
17615      * folds.  We are now in a position that we can do some checks to see if we
17616      * can optimize this ANYOF node into a simpler one, even in Pass 1.
17617      * Currently we only do two checks:
17618      * 1) is in the unlikely event that the user has specified both, eg. \w and
17619      *    \W under /l, then the class matches everything.  (This optimization
17620      *    is done only to make the optimizer code run later work.)
17621      * 2) if the character class contains only a single element (including a
17622      *    single range), we see if there is an equivalent node for it.
17623      * Other checks are possible */
17624     if (   optimizable
17625         && ! ret_invlist   /* Can't optimize if returning the constructed
17626                               inversion list */
17627         && (UNLIKELY(posixl_matches_all) || element_count == 1))
17628     {
17629         U8 op = END;
17630         U8 arg = 0;
17631
17632         if (UNLIKELY(posixl_matches_all)) {
17633             op = SANY;
17634         }
17635         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
17636                                                    class, like \w or [:digit:]
17637                                                    or \p{foo} */
17638
17639             /* All named classes are mapped into POSIXish nodes, with its FLAG
17640              * argument giving which class it is */
17641             switch ((I32)namedclass) {
17642                 case ANYOF_UNIPROP:
17643                     break;
17644
17645                 /* These don't depend on the charset modifiers.  They always
17646                  * match under /u rules */
17647                 case ANYOF_NHORIZWS:
17648                 case ANYOF_HORIZWS:
17649                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
17650                     /* FALLTHROUGH */
17651
17652                 case ANYOF_NVERTWS:
17653                 case ANYOF_VERTWS:
17654                     op = POSIXU;
17655                     goto join_posix;
17656
17657                 /* The actual POSIXish node for all the rest depends on the
17658                  * charset modifier.  The ones in the first set depend only on
17659                  * ASCII or, if available on this platform, also locale */
17660
17661                 case ANYOF_ASCII:
17662                 case ANYOF_NASCII:
17663
17664 #ifdef HAS_ISASCII
17665                     if (LOC) {
17666                         op = POSIXL;
17667                         goto join_posix;
17668                     }
17669 #endif
17670                     /* (named_class - ANYOF_ASCII) is 0 or 1. xor'ing with
17671                      * invert converts that to 1 or 0 */
17672                     op = ASCII + ((namedclass - ANYOF_ASCII) ^ invert);
17673                     break;
17674
17675                 /* The following don't have any matches in the upper Latin1
17676                  * range, hence /d is equivalent to /u for them.  Making it /u
17677                  * saves some branches at runtime */
17678                 case ANYOF_DIGIT:
17679                 case ANYOF_NDIGIT:
17680                 case ANYOF_XDIGIT:
17681                 case ANYOF_NXDIGIT:
17682                     if (! DEPENDS_SEMANTICS) {
17683                         goto treat_as_default;
17684                     }
17685
17686                     op = POSIXU;
17687                     goto join_posix;
17688
17689                 /* The following change to CASED under /i */
17690                 case ANYOF_LOWER:
17691                 case ANYOF_NLOWER:
17692                 case ANYOF_UPPER:
17693                 case ANYOF_NUPPER:
17694                     if (FOLD) {
17695                         namedclass = ANYOF_CASED + (namedclass % 2);
17696                     }
17697                     /* FALLTHROUGH */
17698
17699                 /* The rest have more possibilities depending on the charset.
17700                  * We take advantage of the enum ordering of the charset
17701                  * modifiers to get the exact node type, */
17702                 default:
17703                   treat_as_default:
17704                     op = POSIXD + get_regex_charset(RExC_flags);
17705                     if (op > POSIXA) { /* /aa is same as /a */
17706                         op = POSIXA;
17707                     }
17708
17709                   join_posix:
17710                     /* The odd numbered ones are the complements of the
17711                      * next-lower even number one */
17712                     if (namedclass % 2 == 1) {
17713                         invert = ! invert;
17714                         namedclass--;
17715                     }
17716                     arg = namedclass_to_classnum(namedclass);
17717                     break;
17718             }
17719         }
17720         else if (value == prevvalue) {
17721
17722             /* Here, the class consists of just a single code point */
17723
17724             if (invert) {
17725                 if (! LOC && value == '\n') {
17726                     op = REG_ANY; /* Optimize [^\n] */
17727                     *flagp |= HASWIDTH|SIMPLE;
17728                     MARK_NAUGHTY(1);
17729                 }
17730             }
17731             else if (value < 256 || UTF) {
17732
17733                 /* Optimize a single value into an EXACTish node, but not if it
17734                  * would require converting the pattern to UTF-8. */
17735                 op = compute_EXACTish(pRExC_state);
17736             }
17737         } /* Otherwise is a range */
17738         else if (! LOC) {   /* locale could vary these */
17739             if (prevvalue == '0') {
17740                 if (value == '9') {
17741                     arg = _CC_DIGIT;
17742                     op = POSIXA;
17743                 }
17744             }
17745             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
17746                 /* We can optimize A-Z or a-z, but not if they could match
17747                  * something like the KELVIN SIGN under /i. */
17748                 if (prevvalue == 'A') {
17749                     if (value == 'Z'
17750 #ifdef EBCDIC
17751                         && ! non_portable_endpoint
17752 #endif
17753                     ) {
17754                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
17755                         op = POSIXA;
17756                     }
17757                 }
17758                 else if (prevvalue == 'a') {
17759                     if (value == 'z'
17760 #ifdef EBCDIC
17761                         && ! non_portable_endpoint
17762 #endif
17763                     ) {
17764                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
17765                         op = POSIXA;
17766                     }
17767                 }
17768             }
17769         }
17770
17771         /* Here, we have changed <op> away from its initial value iff we found
17772          * an optimization */
17773         if (op != END) {
17774
17775             /* Throw away this ANYOF regnode, and emit the calculated one,
17776              * which should correspond to the beginning, not current, state of
17777              * the parse */
17778             const char * cur_parse = RExC_parse;
17779             RExC_parse = (char *)orig_parse;
17780             if ( SIZE_ONLY) {
17781                 if (! LOC) {
17782
17783                     /* To get locale nodes to not use the full ANYOF size would
17784                      * require moving the code above that writes the portions
17785                      * of it that aren't in other nodes to after this point.
17786                      * e.g.  ANYOF_POSIXL_SET */
17787                     RExC_size = orig_size;
17788                 }
17789             }
17790             else {
17791                 RExC_emit = (regnode *)orig_emit;
17792                 if (PL_regkind[op] == POSIXD) {
17793                     if (op == POSIXL) {
17794                         RExC_contains_locale = 1;
17795                     }
17796                     if (invert) {
17797                         op += NPOSIXD - POSIXD;
17798                     }
17799                 }
17800             }
17801
17802             ret = reg_node(pRExC_state, op);
17803
17804             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17805                 if (! SIZE_ONLY) {
17806                     FLAGS(ret) = arg;
17807                 }
17808                 *flagp |= HASWIDTH|SIMPLE;
17809             }
17810             else if (PL_regkind[op] == EXACT) {
17811                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17812                                            TRUE /* downgradable to EXACT */
17813                                            );
17814             }
17815             else {
17816                 *flagp |= HASWIDTH|SIMPLE;
17817             }
17818
17819             RExC_parse = (char *) cur_parse;
17820
17821             SvREFCNT_dec(posixes);
17822             SvREFCNT_dec(nposixes);
17823             SvREFCNT_dec(simple_posixes);
17824             SvREFCNT_dec(cp_list);
17825             SvREFCNT_dec(cp_foldable_list);
17826             return ret;
17827         }
17828     }
17829
17830     if (SIZE_ONLY)
17831         return ret;
17832     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17833
17834     /* If folding, we calculate all characters that could fold to or from the
17835      * ones already on the list */
17836     if (cp_foldable_list) {
17837         if (FOLD) {
17838             UV start, end;      /* End points of code point ranges */
17839
17840             SV* fold_intersection = NULL;
17841             SV** use_list;
17842
17843             /* Our calculated list will be for Unicode rules.  For locale
17844              * matching, we have to keep a separate list that is consulted at
17845              * runtime only when the locale indicates Unicode rules.  For
17846              * non-locale, we just use the general list */
17847             if (LOC) {
17848                 use_list = &only_utf8_locale_list;
17849             }
17850             else {
17851                 use_list = &cp_list;
17852             }
17853
17854             /* Only the characters in this class that participate in folds need
17855              * be checked.  Get the intersection of this class and all the
17856              * possible characters that are foldable.  This can quickly narrow
17857              * down a large class */
17858             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17859                                   &fold_intersection);
17860
17861             /* The folds for all the Latin1 characters are hard-coded into this
17862              * program, but we have to go out to disk to get the others. */
17863             if (invlist_highest(cp_foldable_list) >= 256) {
17864
17865                 /* This is a hash that for a particular fold gives all
17866                  * characters that are involved in it */
17867                 if (! PL_utf8_foldclosures) {
17868                     _load_PL_utf8_foldclosures();
17869                 }
17870             }
17871
17872             /* Now look at the foldable characters in this class individually */
17873             invlist_iterinit(fold_intersection);
17874             while (invlist_iternext(fold_intersection, &start, &end)) {
17875                 UV j;
17876
17877                 /* Look at every character in the range */
17878                 for (j = start; j <= end; j++) {
17879                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17880                     STRLEN foldlen;
17881                     SV** listp;
17882
17883                     if (j < 256) {
17884
17885                         if (IS_IN_SOME_FOLD_L1(j)) {
17886
17887                             /* ASCII is always matched; non-ASCII is matched
17888                              * only under Unicode rules (which could happen
17889                              * under /l if the locale is a UTF-8 one */
17890                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17891                                 *use_list = add_cp_to_invlist(*use_list,
17892                                                             PL_fold_latin1[j]);
17893                             }
17894                             else {
17895                                 has_upper_latin1_only_utf8_matches
17896                                     = add_cp_to_invlist(
17897                                             has_upper_latin1_only_utf8_matches,
17898                                             PL_fold_latin1[j]);
17899                             }
17900                         }
17901
17902                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17903                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17904                         {
17905                             add_above_Latin1_folds(pRExC_state,
17906                                                    (U8) j,
17907                                                    use_list);
17908                         }
17909                         continue;
17910                     }
17911
17912                     /* Here is an above Latin1 character.  We don't have the
17913                      * rules hard-coded for it.  First, get its fold.  This is
17914                      * the simple fold, as the multi-character folds have been
17915                      * handled earlier and separated out */
17916                     _to_uni_fold_flags(j, foldbuf, &foldlen,
17917                                                         (ASCII_FOLD_RESTRICTED)
17918                                                         ? FOLD_FLAGS_NOMIX_ASCII
17919                                                         : 0);
17920
17921                     /* Single character fold of above Latin1.  Add everything in
17922                     * its fold closure to the list that this node should match.
17923                     * The fold closures data structure is a hash with the keys
17924                     * being the UTF-8 of every character that is folded to, like
17925                     * 'k', and the values each an array of all code points that
17926                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
17927                     * Multi-character folds are not included */
17928                     if ((listp = hv_fetch(PL_utf8_foldclosures,
17929                                         (char *) foldbuf, foldlen, FALSE)))
17930                     {
17931                         AV* list = (AV*) *listp;
17932                         IV k;
17933                         for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
17934                             SV** c_p = av_fetch(list, k, FALSE);
17935                             UV c;
17936                             assert(c_p);
17937
17938                             c = SvUV(*c_p);
17939
17940                             /* /aa doesn't allow folds between ASCII and non- */
17941                             if ((ASCII_FOLD_RESTRICTED
17942                                 && (isASCII(c) != isASCII(j))))
17943                             {
17944                                 continue;
17945                             }
17946
17947                             /* Folds under /l which cross the 255/256 boundary
17948                              * are added to a separate list.  (These are valid
17949                              * only when the locale is UTF-8.) */
17950                             if (c < 256 && LOC) {
17951                                 *use_list = add_cp_to_invlist(*use_list, c);
17952                                 continue;
17953                             }
17954
17955                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17956                             {
17957                                 cp_list = add_cp_to_invlist(cp_list, c);
17958                             }
17959                             else {
17960                                 /* Similarly folds involving non-ascii Latin1
17961                                 * characters under /d are added to their list */
17962                                 has_upper_latin1_only_utf8_matches
17963                                         = add_cp_to_invlist(
17964                                            has_upper_latin1_only_utf8_matches,
17965                                            c);
17966                             }
17967                         }
17968                     }
17969                 }
17970             }
17971             SvREFCNT_dec_NN(fold_intersection);
17972         }
17973
17974         /* Now that we have finished adding all the folds, there is no reason
17975          * to keep the foldable list separate */
17976         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17977         SvREFCNT_dec_NN(cp_foldable_list);
17978     }
17979
17980     /* And combine the result (if any) with any inversion lists from posix
17981      * classes.  The lists are kept separate up to now because we don't want to
17982      * fold the classes (folding of those is automatically handled by the swash
17983      * fetching code) */
17984     if (simple_posixes) {   /* These are the classes known to be unaffected by
17985                                /a, /aa, and /d */
17986         if (cp_list) {
17987             _invlist_union(cp_list, simple_posixes, &cp_list);
17988             SvREFCNT_dec_NN(simple_posixes);
17989         }
17990         else {
17991             cp_list = simple_posixes;
17992         }
17993     }
17994     if (posixes || nposixes) {
17995
17996         /* We have to adjust /a and /aa */
17997         if (AT_LEAST_ASCII_RESTRICTED) {
17998
17999             /* Under /a and /aa, nothing above ASCII matches these */
18000             if (posixes) {
18001                 _invlist_intersection(posixes,
18002                                     PL_XPosix_ptrs[_CC_ASCII],
18003                                     &posixes);
18004             }
18005
18006             /* Under /a and /aa, everything above ASCII matches these
18007              * complements */
18008             if (nposixes) {
18009                 _invlist_union_complement_2nd(nposixes,
18010                                               PL_XPosix_ptrs[_CC_ASCII],
18011                                               &nposixes);
18012             }
18013         }
18014
18015         if (! DEPENDS_SEMANTICS) {
18016
18017             /* For everything but /d, we can just add the current 'posixes' and
18018              * 'nposixes' to the main list */
18019             if (posixes) {
18020                 if (cp_list) {
18021                     _invlist_union(cp_list, posixes, &cp_list);
18022                     SvREFCNT_dec_NN(posixes);
18023                 }
18024                 else {
18025                     cp_list = posixes;
18026                 }
18027             }
18028             if (nposixes) {
18029                 if (cp_list) {
18030                     _invlist_union(cp_list, nposixes, &cp_list);
18031                     SvREFCNT_dec_NN(nposixes);
18032                 }
18033                 else {
18034                     cp_list = nposixes;
18035                 }
18036             }
18037         }
18038         else {
18039             /* Under /d, things like \w match upper Latin1 characters only if
18040              * the target string is in UTF-8.  But things like \W match all the
18041              * upper Latin1 characters if the target string is not in UTF-8.
18042              *
18043              * Handle the case where there something like \W separately */
18044             if (nposixes) {
18045                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
18046
18047                 /* A complemented posix class matches all upper Latin1
18048                  * characters if not in UTF-8.  And it matches just certain
18049                  * ones when in UTF-8.  That means those certain ones are
18050                  * matched regardless, so can just be added to the
18051                  * unconditional list */
18052                 if (cp_list) {
18053                     _invlist_union(cp_list, nposixes, &cp_list);
18054                     SvREFCNT_dec_NN(nposixes);
18055                     nposixes = NULL;
18056                 }
18057                 else {
18058                     cp_list = nposixes;
18059                 }
18060
18061                 /* Likewise for 'posixes' */
18062                 _invlist_union(posixes, cp_list, &cp_list);
18063
18064                 /* Likewise for anything else in the range that matched only
18065                  * under UTF-8 */
18066                 if (has_upper_latin1_only_utf8_matches) {
18067                     _invlist_union(cp_list,
18068                                    has_upper_latin1_only_utf8_matches,
18069                                    &cp_list);
18070                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
18071                     has_upper_latin1_only_utf8_matches = NULL;
18072                 }
18073
18074                 /* If we don't match all the upper Latin1 characters regardless
18075                  * of UTF-8ness, we have to set a flag to match the rest when
18076                  * not in UTF-8 */
18077                 _invlist_subtract(only_non_utf8_list, cp_list,
18078                                   &only_non_utf8_list);
18079                 if (_invlist_len(only_non_utf8_list) != 0) {
18080                     ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18081                 }
18082                 SvREFCNT_dec_NN(only_non_utf8_list);
18083             }
18084             else {
18085                 /* Here there were no complemented posix classes.  That means
18086                  * the upper Latin1 characters in 'posixes' match only when the
18087                  * target string is in UTF-8.  So we have to add them to the
18088                  * list of those types of code points, while adding the
18089                  * remainder to the unconditional list.
18090                  *
18091                  * First calculate what they are */
18092                 SV* nonascii_but_latin1_properties = NULL;
18093                 _invlist_intersection(posixes, PL_UpperLatin1,
18094                                       &nonascii_but_latin1_properties);
18095
18096                 /* And add them to the final list of such characters. */
18097                 _invlist_union(has_upper_latin1_only_utf8_matches,
18098                                nonascii_but_latin1_properties,
18099                                &has_upper_latin1_only_utf8_matches);
18100
18101                 /* Remove them from what now becomes the unconditional list */
18102                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
18103                                   &posixes);
18104
18105                 /* And add those unconditional ones to the final list */
18106                 if (cp_list) {
18107                     _invlist_union(cp_list, posixes, &cp_list);
18108                     SvREFCNT_dec_NN(posixes);
18109                     posixes = NULL;
18110                 }
18111                 else {
18112                     cp_list = posixes;
18113                 }
18114
18115                 SvREFCNT_dec(nonascii_but_latin1_properties);
18116
18117                 /* Get rid of any characters that we now know are matched
18118                  * unconditionally from the conditional list, which may make
18119                  * that list empty */
18120                 _invlist_subtract(has_upper_latin1_only_utf8_matches,
18121                                   cp_list,
18122                                   &has_upper_latin1_only_utf8_matches);
18123                 if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
18124                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
18125                     has_upper_latin1_only_utf8_matches = NULL;
18126                 }
18127             }
18128         }
18129     }
18130
18131     /* And combine the result (if any) with any inversion list from properties.
18132      * The lists are kept separate up to now so that we can distinguish the two
18133      * in regards to matching above-Unicode.  A run-time warning is generated
18134      * if a Unicode property is matched against a non-Unicode code point. But,
18135      * we allow user-defined properties to match anything, without any warning,
18136      * and we also suppress the warning if there is a portion of the character
18137      * class that isn't a Unicode property, and which matches above Unicode, \W
18138      * or [\x{110000}] for example.
18139      * (Note that in this case, unlike the Posix one above, there is no
18140      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
18141      * forces Unicode semantics */
18142     if (properties) {
18143         if (cp_list) {
18144
18145             /* If it matters to the final outcome, see if a non-property
18146              * component of the class matches above Unicode.  If so, the
18147              * warning gets suppressed.  This is true even if just a single
18148              * such code point is specified, as, though not strictly correct if
18149              * another such code point is matched against, the fact that they
18150              * are using above-Unicode code points indicates they should know
18151              * the issues involved */
18152             if (warn_super) {
18153                 warn_super = ! (invert
18154                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
18155             }
18156
18157             _invlist_union(properties, cp_list, &cp_list);
18158             SvREFCNT_dec_NN(properties);
18159         }
18160         else {
18161             cp_list = properties;
18162         }
18163
18164         if (warn_super) {
18165             ANYOF_FLAGS(ret)
18166              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18167
18168             /* Because an ANYOF node is the only one that warns, this node
18169              * can't be optimized into something else */
18170             optimizable = FALSE;
18171         }
18172     }
18173
18174     /* Here, we have calculated what code points should be in the character
18175      * class.
18176      *
18177      * Now we can see about various optimizations.  Fold calculation (which we
18178      * did above) needs to take place before inversion.  Otherwise /[^k]/i
18179      * would invert to include K, which under /i would match k, which it
18180      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
18181      * folded until runtime */
18182
18183     /* If we didn't do folding, it's because some information isn't available
18184      * until runtime; set the run-time fold flag for these.  (We don't have to
18185      * worry about properties folding, as that is taken care of by the swash
18186      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
18187      * locales, or the class matches at least one 0-255 range code point */
18188     if (LOC && FOLD) {
18189
18190         /* Some things on the list might be unconditionally included because of
18191          * other components.  Remove them, and clean up the list if it goes to
18192          * 0 elements */
18193         if (only_utf8_locale_list && cp_list) {
18194             _invlist_subtract(only_utf8_locale_list, cp_list,
18195                               &only_utf8_locale_list);
18196
18197             if (_invlist_len(only_utf8_locale_list) == 0) {
18198                 SvREFCNT_dec_NN(only_utf8_locale_list);
18199                 only_utf8_locale_list = NULL;
18200             }
18201         }
18202         if (only_utf8_locale_list) {
18203             ANYOF_FLAGS(ret)
18204                  |=  ANYOFL_FOLD
18205                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
18206         }
18207         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
18208             UV start, end;
18209             invlist_iterinit(cp_list);
18210             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
18211                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
18212             }
18213             invlist_iterfinish(cp_list);
18214         }
18215     }
18216     else if (   DEPENDS_SEMANTICS
18217              && (    has_upper_latin1_only_utf8_matches
18218                  || (ANYOF_FLAGS(ret) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
18219     {
18220         OP(ret) = ANYOFD;
18221         optimizable = FALSE;
18222     }
18223
18224
18225     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
18226      * at compile time.  Besides not inverting folded locale now, we can't
18227      * invert if there are things such as \w, which aren't known until runtime
18228      * */
18229     if (cp_list
18230         && invert
18231         && OP(ret) != ANYOFD
18232         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
18233         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
18234     {
18235         _invlist_invert(cp_list);
18236
18237         /* Any swash can't be used as-is, because we've inverted things */
18238         if (swash) {
18239             SvREFCNT_dec_NN(swash);
18240             swash = NULL;
18241         }
18242
18243         /* Clear the invert flag since have just done it here */
18244         invert = FALSE;
18245     }
18246
18247     if (ret_invlist) {
18248         assert(cp_list);
18249
18250         *ret_invlist = cp_list;
18251         SvREFCNT_dec(swash);
18252
18253         /* Discard the generated node */
18254         if (SIZE_ONLY) {
18255             RExC_size = orig_size;
18256         }
18257         else {
18258             RExC_emit = orig_emit;
18259         }
18260         return orig_emit;
18261     }
18262
18263     /* Some character classes are equivalent to other nodes.  Such nodes take
18264      * up less room and generally fewer operations to execute than ANYOF nodes.
18265      * Above, we checked for and optimized into some such equivalents for
18266      * certain common classes that are easy to test.  Getting to this point in
18267      * the code means that the class didn't get optimized there.  Since this
18268      * code is only executed in Pass 2, it is too late to save space--it has
18269      * been allocated in Pass 1, and currently isn't given back.  XXX Why not?
18270      * But turning things into an EXACTish node can allow the optimizer to join
18271      * it to any adjacent such nodes.  And if the class is equivalent to things
18272      * like /./, expensive run-time swashes can be avoided.  Now that we have
18273      * more complete information, we can find things necessarily missed by the
18274      * earlier code. */
18275
18276     if (optimizable && cp_list && ! invert) {
18277         UV start, end;
18278         U8 op = END;  /* The optimzation node-type */
18279         int posix_class = -1;   /* Illegal value */
18280         const char * cur_parse= RExC_parse;
18281         U8 ANYOFM_mask = 0xFF;
18282         U32 anode_arg = 0;
18283
18284         invlist_iterinit(cp_list);
18285         if (! invlist_iternext(cp_list, &start, &end)) {
18286
18287             /* Here, the list is empty.  This happens, for example, when a
18288              * Unicode property that doesn't match anything is the only element
18289              * in the character class (perluniprops.pod notes such properties).
18290              * */
18291             op = OPFAIL;
18292             *flagp |= HASWIDTH|SIMPLE;
18293         }
18294         else if (start == end) {    /* The range is a single code point */
18295             if (! invlist_iternext(cp_list, &start, &end)
18296
18297                     /* Don't do this optimization if it would require changing
18298                      * the pattern to UTF-8 */
18299                 && (start < 256 || UTF))
18300             {
18301                 /* Here, the list contains a single code point.  Can optimize
18302                  * into an EXACTish node */
18303
18304                 value = start;
18305
18306                 if (! FOLD) {
18307                     op = (LOC)
18308                          ? EXACTL
18309                          : EXACT;
18310                 }
18311                 else if (LOC) {
18312
18313                     /* A locale node under folding with one code point can be
18314                      * an EXACTFL, as its fold won't be calculated until
18315                      * runtime */
18316                     op = EXACTFL;
18317                 }
18318                 else {
18319
18320                     /* Here, we are generally folding, but there is only one
18321                      * code point to match.  If we have to, we use an EXACT
18322                      * node, but it would be better for joining with adjacent
18323                      * nodes in the optimization pass if we used the same
18324                      * EXACTFish node that any such are likely to be.  We can
18325                      * do this iff the code point doesn't participate in any
18326                      * folds.  For example, an EXACTF of a colon is the same as
18327                      * an EXACT one, since nothing folds to or from a colon. */
18328                     if (value < 256) {
18329                         if (IS_IN_SOME_FOLD_L1(value)) {
18330                             op = EXACT;
18331                         }
18332                     }
18333                     else {
18334                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
18335                             op = EXACT;
18336                         }
18337                     }
18338
18339                     /* If we haven't found the node type, above, it means we
18340                      * can use the prevailing one */
18341                     if (op == END) {
18342                         op = compute_EXACTish(pRExC_state);
18343                     }
18344                 }
18345             }
18346         }   /* End of first range contains just a single code point */
18347         else if (start == 0) {
18348             if (end == UV_MAX) {
18349                 op = SANY;
18350                 *flagp |= HASWIDTH|SIMPLE;
18351                 MARK_NAUGHTY(1);
18352             }
18353             else if (end == '\n' - 1
18354                     && invlist_iternext(cp_list, &start, &end)
18355                     && start == '\n' + 1 && end == UV_MAX)
18356             {
18357                 op = REG_ANY;
18358                 *flagp |= HASWIDTH|SIMPLE;
18359                 MARK_NAUGHTY(1);
18360             }
18361         }
18362         invlist_iterfinish(cp_list);
18363
18364         if (op == END) {
18365
18366             /* Here, didn't find an optimization.  See if this matches any of
18367              * the POSIX classes.  First try ASCII */
18368
18369             if (_invlistEQ(cp_list, PL_XPosix_ptrs[_CC_ASCII], 0)) {
18370                 op = ASCII;
18371                 *flagp |= HASWIDTH|SIMPLE;
18372             }
18373             else if (_invlistEQ(cp_list, PL_XPosix_ptrs[_CC_ASCII], 1)) {
18374                 op = NASCII;
18375                 *flagp |= HASWIDTH|SIMPLE;
18376             }
18377             else if (invlist_highest(cp_list) >= 0x2029) {
18378
18379                 /* Then try the other POSIX classes.  The POSIXA ones are about
18380                  * the same speed as ANYOF ops, but the ones that have
18381                  * above-Latin1 code point matches are somewhat faster than
18382                  * ANYOF.  So optimize those, but don't bother with the POSIXA
18383                  * ones nor [:cntrl:] which has no above-Latin1 matches.  If
18384                  * this ANYOF node has a lower highest possible matching code
18385                  * point than any of the XPosix ones, we know that it can't
18386                  * possibly be the same as any of them, so we can avoid
18387                  * executing this code.  The 0x2029 above for the lowest max
18388                  * was determined by manual inspection of the classes, and
18389                  * comes from \v.  Suppose Unicode in a later version adds a
18390                  * higher code point to \v.  All that means is that this code
18391                  * can be executed unnecessarily.  It will still give the
18392                  * correct answer. */
18393
18394                 for (posix_class = 0;
18395                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
18396                      posix_class++)
18397                 {
18398                     int try_inverted;
18399
18400                     if (posix_class == _CC_CNTRL) {
18401                         continue;
18402                     }
18403
18404                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
18405
18406                         /* Check if matches normal or inverted */
18407                         if (_invlistEQ(cp_list,
18408                                        PL_XPosix_ptrs[posix_class],
18409                                        try_inverted))
18410                         {
18411                             op = (try_inverted)
18412                                  ? NPOSIXU
18413                                  : POSIXU;
18414                             *flagp |= HASWIDTH|SIMPLE;
18415                             goto found_posix;
18416                         }
18417                     }
18418                 }
18419               found_posix: ;
18420             }
18421
18422             /* If it didn't match a POSIX class, it might be able to be turned
18423              * into an ANYOFM node.  Compare two different bytes, bit-by-bit.
18424              * In some positions, the bits in each will be 1; and in other
18425              * positions both will be 0; and in some positions the bit will be
18426              * 1 in one byte, and 0 in the other.  Let 'n' be the number of
18427              * positions where the bits differ.  We create a mask which has
18428              * exactly 'n' 0 bits, each in a position where the two bytes
18429              * differ.  Now take the set of all bytes that when ANDed with the
18430              * mask yield the same result.  That set has 2**n elements, and is
18431              * representable by just two 8 bit numbers: the result and the
18432              * mask.  Importantly, matching the set can be vectorized by
18433              * creating a word full of the result bytes, and a word full of the
18434              * mask bytes, yielding a significant speed up.  Here, see if this
18435              * node matches such a set.  As a concrete example consider [01],
18436              * and the byte representing '0' which is 0x30 on ASCII machines.
18437              * It has the bits 0011 0000.  Take the mask 1111 1110.  If we AND
18438              * 0x31 and 0x30 with that mask we get 0x30.  Any other bytes ANDed
18439              * yield something else.  So [01], which is a common usage, is
18440              * optimizable into ANYOFM, and can benefit from the speed up.  We
18441              * can only do this on UTF-8 invariant bytes, because the variance
18442              * would throw this off.  */
18443             if (   op == END
18444                 && invlist_highest(cp_list) <=
18445 #ifdef EBCDIC
18446                                                0xFF
18447 #else
18448                                                0x7F
18449 #endif
18450             ) {
18451                 Size_t cp_count = 0;
18452                 bool first_time = TRUE;
18453                 unsigned int lowest_cp = 0xFF;
18454                 U8 bits_differing = 0;
18455
18456                 /* Only needed on EBCDIC, as there, variants and non- are mixed
18457                  * together.  Could #ifdef it out on ASCII, but probably the
18458                  * compiler will optimize it out */
18459                 bool has_variant = FALSE;
18460
18461                 /* Go through the bytes and find the bit positions that differ */
18462                 invlist_iterinit(cp_list);
18463                 while (invlist_iternext(cp_list, &start, &end)) {
18464                     unsigned int i = start;
18465
18466                     cp_count += end - start + 1;
18467
18468                     if (first_time) {
18469                         if (! UVCHR_IS_INVARIANT(i)) {
18470                             has_variant = TRUE;
18471                             continue;
18472                         }
18473
18474                         first_time = FALSE;
18475                         lowest_cp = start;
18476
18477                         i++;
18478                     }
18479
18480                     /* Find the bit positions that differ from the lowest code
18481                      * point in the node.  Keep track of all such positions by
18482                      * OR'ing */
18483                     for (; i <= end; i++) {
18484                         if (! UVCHR_IS_INVARIANT(i)) {
18485                             has_variant = TRUE;
18486                             continue;
18487                         }
18488
18489                         bits_differing  |= i ^ lowest_cp;
18490                     }
18491                 }
18492                 invlist_iterfinish(cp_list);
18493
18494                 /* At the end of the loop, we count how many bits differ from
18495                  * the bits in lowest code point, call the count 'd'.  If the
18496                  * set we found contains 2**d elements, it is the closure of
18497                  * all code points that differ only in those bit positions.  To
18498                  * convince yourself of that, first note that the number in the
18499                  * closure must be a power of 2, which we test for.  The only
18500                  * way we could have that count and it be some differing set,
18501                  * is if we got some code points that don't differ from the
18502                  * lowest code point in any position, but do differ from each
18503                  * other in some other position.  That means one code point has
18504                  * a 1 in that position, and another has a 0.  But that would
18505                  * mean that one of them differs from the lowest code point in
18506                  * that position, which possibility we've already excluded. */
18507                 if ( ! has_variant
18508                     && cp_count == 1U << PL_bitcount[bits_differing])
18509                 {
18510                     assert(cp_count > 1);
18511                     op = ANYOFM;
18512
18513                     /* We need to make the bits that differ be 0's */
18514                     ANYOFM_mask = ~ bits_differing; /* This goes into FLAGS */
18515
18516                     /* The argument is the lowest code point */
18517                     anode_arg = lowest_cp;
18518                     *flagp |= HASWIDTH|SIMPLE;
18519                 }
18520             }
18521         }
18522
18523         if (op != END) {
18524             RExC_parse = (char *)orig_parse;
18525             RExC_emit = (regnode *)orig_emit;
18526
18527             if (regarglen[op]) {
18528                 ret = reganode(pRExC_state, op, anode_arg);
18529             } else {
18530                 ret = reg_node(pRExC_state, op);
18531             }
18532
18533             RExC_parse = (char *)cur_parse;
18534
18535             if (PL_regkind[op] == EXACT) {
18536                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
18537                                            TRUE /* downgradable to EXACT */
18538                                           );
18539             }
18540             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
18541                 FLAGS(ret) = posix_class;
18542             }
18543             else if (PL_regkind[op] == ANYOFM) {
18544                 FLAGS(ret) = ANYOFM_mask;
18545             }
18546
18547             SvREFCNT_dec_NN(cp_list);
18548             return ret;
18549         }
18550     }
18551
18552     /* Here, <cp_list> contains all the code points we can determine at
18553      * compile time that match under all conditions.  Go through it, and
18554      * for things that belong in the bitmap, put them there, and delete from
18555      * <cp_list>.  While we are at it, see if everything above 255 is in the
18556      * list, and if so, set a flag to speed up execution */
18557
18558     populate_ANYOF_from_invlist(ret, &cp_list);
18559
18560     if (invert) {
18561         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
18562     }
18563
18564     /* Here, the bitmap has been populated with all the Latin1 code points that
18565      * always match.  Can now add to the overall list those that match only
18566      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
18567      * */
18568     if (has_upper_latin1_only_utf8_matches) {
18569         if (cp_list) {
18570             _invlist_union(cp_list,
18571                            has_upper_latin1_only_utf8_matches,
18572                            &cp_list);
18573             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
18574         }
18575         else {
18576             cp_list = has_upper_latin1_only_utf8_matches;
18577         }
18578         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
18579     }
18580
18581     /* If there is a swash and more than one element, we can't use the swash in
18582      * the optimization below. */
18583     if (swash && element_count > 1) {
18584         SvREFCNT_dec_NN(swash);
18585         swash = NULL;
18586     }
18587
18588     /* Note that the optimization of using 'swash' if it is the only thing in
18589      * the class doesn't have us change swash at all, so it can include things
18590      * that are also in the bitmap; otherwise we have purposely deleted that
18591      * duplicate information */
18592     set_ANYOF_arg(pRExC_state, ret, cp_list,
18593                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
18594                    ? listsv : NULL,
18595                   only_utf8_locale_list,
18596                   swash, has_user_defined_property);
18597
18598     *flagp |= HASWIDTH|SIMPLE;
18599
18600     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
18601         RExC_contains_locale = 1;
18602     }
18603
18604     return ret;
18605 }
18606
18607 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
18608
18609 STATIC void
18610 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
18611                 regnode* const node,
18612                 SV* const cp_list,
18613                 SV* const runtime_defns,
18614                 SV* const only_utf8_locale_list,
18615                 SV* const swash,
18616                 const bool has_user_defined_property)
18617 {
18618     /* Sets the arg field of an ANYOF-type node 'node', using information about
18619      * the node passed-in.  If there is nothing outside the node's bitmap, the
18620      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
18621      * the count returned by add_data(), having allocated and stored an array,
18622      * av, that that count references, as follows:
18623      *  av[0] stores the character class description in its textual form.
18624      *        This is used later (regexec.c:Perl_regclass_swash()) to
18625      *        initialize the appropriate swash, and is also useful for dumping
18626      *        the regnode.  This is set to &PL_sv_undef if the textual
18627      *        description is not needed at run-time (as happens if the other
18628      *        elements completely define the class)
18629      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
18630      *        computed from av[0].  But if no further computation need be done,
18631      *        the swash is stored here now (and av[0] is &PL_sv_undef).
18632      *  av[2] stores the inversion list of code points that match only if the
18633      *        current locale is UTF-8
18634      *  av[3] stores the cp_list inversion list for use in addition or instead
18635      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
18636      *        (Otherwise everything needed is already in av[0] and av[1])
18637      *  av[4] is set if any component of the class is from a user-defined
18638      *        property; used only if av[3] exists */
18639
18640     UV n;
18641
18642     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
18643
18644     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
18645         assert(! (ANYOF_FLAGS(node)
18646                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
18647         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
18648     }
18649     else {
18650         AV * const av = newAV();
18651         SV *rv;
18652
18653         av_store(av, 0, (runtime_defns)
18654                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
18655         if (swash) {
18656             assert(cp_list);
18657             av_store(av, 1, swash);
18658             SvREFCNT_dec_NN(cp_list);
18659         }
18660         else {
18661             av_store(av, 1, &PL_sv_undef);
18662             if (cp_list) {
18663                 av_store(av, 3, cp_list);
18664                 av_store(av, 4, newSVuv(has_user_defined_property));
18665             }
18666         }
18667
18668         if (only_utf8_locale_list) {
18669             av_store(av, 2, only_utf8_locale_list);
18670         }
18671         else {
18672             av_store(av, 2, &PL_sv_undef);
18673         }
18674
18675         rv = newRV_noinc(MUTABLE_SV(av));
18676         n = add_data(pRExC_state, STR_WITH_LEN("s"));
18677         RExC_rxi->data->data[n] = (void*)rv;
18678         ARG_SET(node, n);
18679     }
18680 }
18681
18682 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
18683 SV *
18684 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
18685                                         const regnode* node,
18686                                         bool doinit,
18687                                         SV** listsvp,
18688                                         SV** only_utf8_locale_ptr,
18689                                         SV** output_invlist)
18690
18691 {
18692     /* For internal core use only.
18693      * Returns the swash for the input 'node' in the regex 'prog'.
18694      * If <doinit> is 'true', will attempt to create the swash if not already
18695      *    done.
18696      * If <listsvp> is non-null, will return the printable contents of the
18697      *    swash.  This can be used to get debugging information even before the
18698      *    swash exists, by calling this function with 'doinit' set to false, in
18699      *    which case the components that will be used to eventually create the
18700      *    swash are returned  (in a printable form).
18701      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
18702      *    store an inversion list of code points that should match only if the
18703      *    execution-time locale is a UTF-8 one.
18704      * If <output_invlist> is not NULL, it is where this routine is to store an
18705      *    inversion list of the code points that would be instead returned in
18706      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
18707      *    when this parameter is used, is just the non-code point data that
18708      *    will go into creating the swash.  This currently should be just
18709      *    user-defined properties whose definitions were not known at compile
18710      *    time.  Using this parameter allows for easier manipulation of the
18711      *    swash's data by the caller.  It is illegal to call this function with
18712      *    this parameter set, but not <listsvp>
18713      *
18714      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
18715      * that, in spite of this function's name, the swash it returns may include
18716      * the bitmap data as well */
18717
18718     SV *sw  = NULL;
18719     SV *si  = NULL;         /* Input swash initialization string */
18720     SV* invlist = NULL;
18721
18722     RXi_GET_DECL(prog,progi);
18723     const struct reg_data * const data = prog ? progi->data : NULL;
18724
18725     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
18726     assert(! output_invlist || listsvp);
18727
18728     if (data && data->count) {
18729         const U32 n = ARG(node);
18730
18731         if (data->what[n] == 's') {
18732             SV * const rv = MUTABLE_SV(data->data[n]);
18733             AV * const av = MUTABLE_AV(SvRV(rv));
18734             SV **const ary = AvARRAY(av);
18735             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
18736
18737             si = *ary;  /* ary[0] = the string to initialize the swash with */
18738
18739             if (av_tindex_skip_len_mg(av) >= 2) {
18740                 if (only_utf8_locale_ptr
18741                     && ary[2]
18742                     && ary[2] != &PL_sv_undef)
18743                 {
18744                     *only_utf8_locale_ptr = ary[2];
18745                 }
18746                 else {
18747                     assert(only_utf8_locale_ptr);
18748                     *only_utf8_locale_ptr = NULL;
18749                 }
18750
18751                 /* Elements 3 and 4 are either both present or both absent. [3]
18752                  * is any inversion list generated at compile time; [4]
18753                  * indicates if that inversion list has any user-defined
18754                  * properties in it. */
18755                 if (av_tindex_skip_len_mg(av) >= 3) {
18756                     invlist = ary[3];
18757                     if (SvUV(ary[4])) {
18758                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
18759                     }
18760                 }
18761                 else {
18762                     invlist = NULL;
18763                 }
18764             }
18765
18766             /* Element [1] is reserved for the set-up swash.  If already there,
18767              * return it; if not, create it and store it there */
18768             if (ary[1] && SvROK(ary[1])) {
18769                 sw = ary[1];
18770             }
18771             else if (doinit && ((si && si != &PL_sv_undef)
18772                                  || (invlist && invlist != &PL_sv_undef))) {
18773                 assert(si);
18774                 sw = _core_swash_init("utf8", /* the utf8 package */
18775                                       "", /* nameless */
18776                                       si,
18777                                       1, /* binary */
18778                                       0, /* not from tr/// */
18779                                       invlist,
18780                                       &swash_init_flags);
18781                 (void)av_store(av, 1, sw);
18782             }
18783         }
18784     }
18785
18786     /* If requested, return a printable version of what this swash matches */
18787     if (listsvp) {
18788         SV* matches_string = NULL;
18789
18790         /* The swash should be used, if possible, to get the data, as it
18791          * contains the resolved data.  But this function can be called at
18792          * compile-time, before everything gets resolved, in which case we
18793          * return the currently best available information, which is the string
18794          * that will eventually be used to do that resolving, 'si' */
18795         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
18796             && (si && si != &PL_sv_undef))
18797         {
18798             /* Here, we only have 'si' (and possibly some passed-in data in
18799              * 'invlist', which is handled below)  If the caller only wants
18800              * 'si', use that.  */
18801             if (! output_invlist) {
18802                 matches_string = newSVsv(si);
18803             }
18804             else {
18805                 /* But if the caller wants an inversion list of the node, we
18806                  * need to parse 'si' and place as much as possible in the
18807                  * desired output inversion list, making 'matches_string' only
18808                  * contain the currently unresolvable things */
18809                 const char *si_string = SvPVX(si);
18810                 STRLEN remaining = SvCUR(si);
18811                 UV prev_cp = 0;
18812                 U8 count = 0;
18813
18814                 /* Ignore everything before the first new-line */
18815                 while (*si_string != '\n' && remaining > 0) {
18816                     si_string++;
18817                     remaining--;
18818                 }
18819                 assert(remaining > 0);
18820
18821                 si_string++;
18822                 remaining--;
18823
18824                 while (remaining > 0) {
18825
18826                     /* The data consists of just strings defining user-defined
18827                      * property names, but in prior incarnations, and perhaps
18828                      * somehow from pluggable regex engines, it could still
18829                      * hold hex code point definitions.  Each component of a
18830                      * range would be separated by a tab, and each range by a
18831                      * new-line.  If these are found, instead add them to the
18832                      * inversion list */
18833                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
18834                                      |PERL_SCAN_SILENT_NON_PORTABLE;
18835                     STRLEN len = remaining;
18836                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
18837
18838                     /* If the hex decode routine found something, it should go
18839                      * up to the next \n */
18840                     if (   *(si_string + len) == '\n') {
18841                         if (count) {    /* 2nd code point on line */
18842                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
18843                         }
18844                         else {
18845                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
18846                         }
18847                         count = 0;
18848                         goto prepare_for_next_iteration;
18849                     }
18850
18851                     /* If the hex decode was instead for the lower range limit,
18852                      * save it, and go parse the upper range limit */
18853                     if (*(si_string + len) == '\t') {
18854                         assert(count == 0);
18855
18856                         prev_cp = cp;
18857                         count = 1;
18858                       prepare_for_next_iteration:
18859                         si_string += len + 1;
18860                         remaining -= len + 1;
18861                         continue;
18862                     }
18863
18864                     /* Here, didn't find a legal hex number.  Just add it from
18865                      * here to the next \n */
18866
18867                     remaining -= len;
18868                     while (*(si_string + len) != '\n' && remaining > 0) {
18869                         remaining--;
18870                         len++;
18871                     }
18872                     if (*(si_string + len) == '\n') {
18873                         len++;
18874                         remaining--;
18875                     }
18876                     if (matches_string) {
18877                         sv_catpvn(matches_string, si_string, len - 1);
18878                     }
18879                     else {
18880                         matches_string = newSVpvn(si_string, len - 1);
18881                     }
18882                     si_string += len;
18883                     sv_catpvs(matches_string, " ");
18884                 } /* end of loop through the text */
18885
18886                 assert(matches_string);
18887                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
18888                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
18889                 }
18890             } /* end of has an 'si' but no swash */
18891         }
18892
18893         /* If we have a swash in place, its equivalent inversion list was above
18894          * placed into 'invlist'.  If not, this variable may contain a stored
18895          * inversion list which is information beyond what is in 'si' */
18896         if (invlist) {
18897
18898             /* Again, if the caller doesn't want the output inversion list, put
18899              * everything in 'matches-string' */
18900             if (! output_invlist) {
18901                 if ( ! matches_string) {
18902                     matches_string = newSVpvs("\n");
18903                 }
18904                 sv_catsv(matches_string, invlist_contents(invlist,
18905                                                   TRUE /* traditional style */
18906                                                   ));
18907             }
18908             else if (! *output_invlist) {
18909                 *output_invlist = invlist_clone(invlist);
18910             }
18911             else {
18912                 _invlist_union(*output_invlist, invlist, output_invlist);
18913             }
18914         }
18915
18916         *listsvp = matches_string;
18917     }
18918
18919     return sw;
18920 }
18921 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18922
18923 /* reg_skipcomment()
18924
18925    Absorbs an /x style # comment from the input stream,
18926    returning a pointer to the first character beyond the comment, or if the
18927    comment terminates the pattern without anything following it, this returns
18928    one past the final character of the pattern (in other words, RExC_end) and
18929    sets the REG_RUN_ON_COMMENT_SEEN flag.
18930
18931    Note it's the callers responsibility to ensure that we are
18932    actually in /x mode
18933
18934 */
18935
18936 PERL_STATIC_INLINE char*
18937 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18938 {
18939     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18940
18941     assert(*p == '#');
18942
18943     while (p < RExC_end) {
18944         if (*(++p) == '\n') {
18945             return p+1;
18946         }
18947     }
18948
18949     /* we ran off the end of the pattern without ending the comment, so we have
18950      * to add an \n when wrapping */
18951     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18952     return p;
18953 }
18954
18955 STATIC void
18956 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18957                                 char ** p,
18958                                 const bool force_to_xmod
18959                          )
18960 {
18961     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18962      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18963      * is /x whitespace, advance '*p' so that on exit it points to the first
18964      * byte past all such white space and comments */
18965
18966     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18967
18968     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18969
18970     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18971
18972     for (;;) {
18973         if (RExC_end - (*p) >= 3
18974             && *(*p)     == '('
18975             && *(*p + 1) == '?'
18976             && *(*p + 2) == '#')
18977         {
18978             while (*(*p) != ')') {
18979                 if ((*p) == RExC_end)
18980                     FAIL("Sequence (?#... not terminated");
18981                 (*p)++;
18982             }
18983             (*p)++;
18984             continue;
18985         }
18986
18987         if (use_xmod) {
18988             const char * save_p = *p;
18989             while ((*p) < RExC_end) {
18990                 STRLEN len;
18991                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18992                     (*p) += len;
18993                 }
18994                 else if (*(*p) == '#') {
18995                     (*p) = reg_skipcomment(pRExC_state, (*p));
18996                 }
18997                 else {
18998                     break;
18999                 }
19000             }
19001             if (*p != save_p) {
19002                 continue;
19003             }
19004         }
19005
19006         break;
19007     }
19008
19009     return;
19010 }
19011
19012 /* nextchar()
19013
19014    Advances the parse position by one byte, unless that byte is the beginning
19015    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
19016    those two cases, the parse position is advanced beyond all such comments and
19017    white space.
19018
19019    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
19020 */
19021
19022 STATIC void
19023 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
19024 {
19025     PERL_ARGS_ASSERT_NEXTCHAR;
19026
19027     if (RExC_parse < RExC_end) {
19028         assert(   ! UTF
19029                || UTF8_IS_INVARIANT(*RExC_parse)
19030                || UTF8_IS_START(*RExC_parse));
19031
19032         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
19033
19034         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
19035                                 FALSE /* Don't force /x */ );
19036     }
19037 }
19038
19039 STATIC regnode *
19040 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
19041 {
19042     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
19043      * space.  In pass1, it aligns and increments RExC_size; in pass2,
19044      * RExC_emit */
19045
19046     regnode * const ret = RExC_emit;
19047     GET_RE_DEBUG_FLAGS_DECL;
19048
19049     PERL_ARGS_ASSERT_REGNODE_GUTS;
19050
19051     assert(extra_size >= regarglen[op]);
19052
19053     if (SIZE_ONLY) {
19054         SIZE_ALIGN(RExC_size);
19055         RExC_size += 1 + extra_size;
19056         return(ret);
19057     }
19058     if (RExC_emit >= RExC_emit_bound)
19059         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
19060                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
19061
19062     NODE_ALIGN_FILL(ret);
19063 #ifndef RE_TRACK_PATTERN_OFFSETS
19064     PERL_UNUSED_ARG(name);
19065 #else
19066     if (RExC_offsets) {         /* MJD */
19067         MJD_OFFSET_DEBUG(
19068               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
19069               name, __LINE__,
19070               PL_reg_name[op],
19071               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
19072                 ? "Overwriting end of array!\n" : "OK",
19073               (UV)(RExC_emit - RExC_emit_start),
19074               (UV)(RExC_parse - RExC_start),
19075               (UV)RExC_offsets[0]));
19076         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
19077     }
19078 #endif
19079     return(ret);
19080 }
19081
19082 /*
19083 - reg_node - emit a node
19084 */
19085 STATIC regnode *                        /* Location. */
19086 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
19087 {
19088     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
19089
19090     PERL_ARGS_ASSERT_REG_NODE;
19091
19092     assert(regarglen[op] == 0);
19093
19094     if (PASS2) {
19095         regnode *ptr = ret;
19096         FILL_ADVANCE_NODE(ptr, op);
19097         RExC_emit = ptr;
19098     }
19099     return(ret);
19100 }
19101
19102 /*
19103 - reganode - emit a node with an argument
19104 */
19105 STATIC regnode *                        /* Location. */
19106 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
19107 {
19108     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
19109
19110     PERL_ARGS_ASSERT_REGANODE;
19111
19112     assert(regarglen[op] == 1);
19113
19114     if (PASS2) {
19115         regnode *ptr = ret;
19116         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
19117         RExC_emit = ptr;
19118     }
19119     return(ret);
19120 }
19121
19122 STATIC regnode *
19123 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
19124 {
19125     /* emit a node with U32 and I32 arguments */
19126
19127     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
19128
19129     PERL_ARGS_ASSERT_REG2LANODE;
19130
19131     assert(regarglen[op] == 2);
19132
19133     if (PASS2) {
19134         regnode *ptr = ret;
19135         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
19136         RExC_emit = ptr;
19137     }
19138     return(ret);
19139 }
19140
19141 /*
19142 - reginsert - insert an operator in front of already-emitted operand
19143 *
19144 * Means relocating the operand.
19145 *
19146 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
19147 * set up NEXT_OFF() of the inserted node if needed. Something like this:
19148 *
19149 * reginsert(pRExC, OPFAIL, orig_emit, depth+1);
19150 * if (PASS2)
19151 *     NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
19152 *
19153 * ALSO NOTE - operand->flags will be set to 0 as well.
19154 */
19155 STATIC void
19156 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth)
19157 {
19158     regnode *src;
19159     regnode *dst;
19160     regnode *place;
19161     const int offset = regarglen[(U8)op];
19162     const int size = NODE_STEP_REGNODE + offset;
19163     GET_RE_DEBUG_FLAGS_DECL;
19164
19165     PERL_ARGS_ASSERT_REGINSERT;
19166     PERL_UNUSED_CONTEXT;
19167     PERL_UNUSED_ARG(depth);
19168 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
19169     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
19170     if (SIZE_ONLY) {
19171         RExC_size += size;
19172         return;
19173     }
19174     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
19175                                     studying. If this is wrong then we need to adjust RExC_recurse
19176                                     below like we do with RExC_open_parens/RExC_close_parens. */
19177     src = RExC_emit;
19178     RExC_emit += size;
19179     dst = RExC_emit;
19180     if (RExC_open_parens) {
19181         int paren;
19182         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
19183         /* remember that RExC_npar is rex->nparens + 1,
19184          * iow it is 1 more than the number of parens seen in
19185          * the pattern so far. */
19186         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
19187             /* note, RExC_open_parens[0] is the start of the
19188              * regex, it can't move. RExC_close_parens[0] is the end
19189              * of the regex, it *can* move. */
19190             if ( paren && RExC_open_parens[paren] >= operand ) {
19191                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
19192                 RExC_open_parens[paren] += size;
19193             } else {
19194                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
19195             }
19196             if ( RExC_close_parens[paren] >= operand ) {
19197                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
19198                 RExC_close_parens[paren] += size;
19199             } else {
19200                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
19201             }
19202         }
19203     }
19204     if (RExC_end_op)
19205         RExC_end_op += size;
19206
19207     while (src > operand) {
19208         StructCopy(--src, --dst, regnode);
19209 #ifdef RE_TRACK_PATTERN_OFFSETS
19210         if (RExC_offsets) {     /* MJD 20010112 */
19211             MJD_OFFSET_DEBUG(
19212                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
19213                   "reg_insert",
19214                   __LINE__,
19215                   PL_reg_name[op],
19216                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
19217                     ? "Overwriting end of array!\n" : "OK",
19218                   (UV)(src - RExC_emit_start),
19219                   (UV)(dst - RExC_emit_start),
19220                   (UV)RExC_offsets[0]));
19221             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
19222             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
19223         }
19224 #endif
19225     }
19226
19227     place = operand;            /* Op node, where operand used to be. */
19228 #ifdef RE_TRACK_PATTERN_OFFSETS
19229     if (RExC_offsets) {         /* MJD */
19230         MJD_OFFSET_DEBUG(
19231               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
19232               "reginsert",
19233               __LINE__,
19234               PL_reg_name[op],
19235               (UV)(place - RExC_emit_start) > RExC_offsets[0]
19236               ? "Overwriting end of array!\n" : "OK",
19237               (UV)(place - RExC_emit_start),
19238               (UV)(RExC_parse - RExC_start),
19239               (UV)RExC_offsets[0]));
19240         Set_Node_Offset(place, RExC_parse);
19241         Set_Node_Length(place, 1);
19242     }
19243 #endif
19244     src = NEXTOPER(place);
19245     place->flags = 0;
19246     FILL_ADVANCE_NODE(place, op);
19247     Zero(src, offset, regnode);
19248 }
19249
19250 /*
19251 - regtail - set the next-pointer at the end of a node chain of p to val.
19252 - SEE ALSO: regtail_study
19253 */
19254 STATIC void
19255 S_regtail(pTHX_ RExC_state_t * pRExC_state,
19256                 const regnode * const p,
19257                 const regnode * const val,
19258                 const U32 depth)
19259 {
19260     regnode *scan;
19261     GET_RE_DEBUG_FLAGS_DECL;
19262
19263     PERL_ARGS_ASSERT_REGTAIL;
19264 #ifndef DEBUGGING
19265     PERL_UNUSED_ARG(depth);
19266 #endif
19267
19268     if (SIZE_ONLY)
19269         return;
19270
19271     /* Find last node. */
19272     scan = (regnode *) p;
19273     for (;;) {
19274         regnode * const temp = regnext(scan);
19275         DEBUG_PARSE_r({
19276             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
19277             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
19278             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
19279                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
19280                     (temp == NULL ? "->" : ""),
19281                     (temp == NULL ? PL_reg_name[OP(val)] : "")
19282             );
19283         });
19284         if (temp == NULL)
19285             break;
19286         scan = temp;
19287     }
19288
19289     if (reg_off_by_arg[OP(scan)]) {
19290         ARG_SET(scan, val - scan);
19291     }
19292     else {
19293         NEXT_OFF(scan) = val - scan;
19294     }
19295 }
19296
19297 #ifdef DEBUGGING
19298 /*
19299 - regtail_study - set the next-pointer at the end of a node chain of p to val.
19300 - Look for optimizable sequences at the same time.
19301 - currently only looks for EXACT chains.
19302
19303 This is experimental code. The idea is to use this routine to perform
19304 in place optimizations on branches and groups as they are constructed,
19305 with the long term intention of removing optimization from study_chunk so
19306 that it is purely analytical.
19307
19308 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
19309 to control which is which.
19310
19311 */
19312 /* TODO: All four parms should be const */
19313
19314 STATIC U8
19315 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
19316                       const regnode *val,U32 depth)
19317 {
19318     regnode *scan;
19319     U8 exact = PSEUDO;
19320 #ifdef EXPERIMENTAL_INPLACESCAN
19321     I32 min = 0;
19322 #endif
19323     GET_RE_DEBUG_FLAGS_DECL;
19324
19325     PERL_ARGS_ASSERT_REGTAIL_STUDY;
19326
19327
19328     if (SIZE_ONLY)
19329         return exact;
19330
19331     /* Find last node. */
19332
19333     scan = p;
19334     for (;;) {
19335         regnode * const temp = regnext(scan);
19336 #ifdef EXPERIMENTAL_INPLACESCAN
19337         if (PL_regkind[OP(scan)] == EXACT) {
19338             bool unfolded_multi_char;   /* Unexamined in this routine */
19339             if (join_exact(pRExC_state, scan, &min,
19340                            &unfolded_multi_char, 1, val, depth+1))
19341                 return EXACT;
19342         }
19343 #endif
19344         if ( exact ) {
19345             switch (OP(scan)) {
19346                 case EXACT:
19347                 case EXACTL:
19348                 case EXACTF:
19349                 case EXACTFAA_NO_TRIE:
19350                 case EXACTFAA:
19351                 case EXACTFU:
19352                 case EXACTFLU8:
19353                 case EXACTFU_SS:
19354                 case EXACTFL:
19355                         if( exact == PSEUDO )
19356                             exact= OP(scan);
19357                         else if ( exact != OP(scan) )
19358                             exact= 0;
19359                 case NOTHING:
19360                     break;
19361                 default:
19362                     exact= 0;
19363             }
19364         }
19365         DEBUG_PARSE_r({
19366             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
19367             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
19368             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
19369                 SvPV_nolen_const(RExC_mysv),
19370                 REG_NODE_NUM(scan),
19371                 PL_reg_name[exact]);
19372         });
19373         if (temp == NULL)
19374             break;
19375         scan = temp;
19376     }
19377     DEBUG_PARSE_r({
19378         DEBUG_PARSE_MSG("");
19379         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
19380         Perl_re_printf( aTHX_
19381                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
19382                       SvPV_nolen_const(RExC_mysv),
19383                       (IV)REG_NODE_NUM(val),
19384                       (IV)(val - scan)
19385         );
19386     });
19387     if (reg_off_by_arg[OP(scan)]) {
19388         ARG_SET(scan, val - scan);
19389     }
19390     else {
19391         NEXT_OFF(scan) = val - scan;
19392     }
19393
19394     return exact;
19395 }
19396 #endif
19397
19398 STATIC SV*
19399 S_get_ANYOFM_contents(pTHX_ const regnode * n) {
19400
19401     /* Returns an inversion list of all the code points matched by the ANYOFM
19402      * node 'n' */
19403
19404     SV * cp_list = _new_invlist(-1);
19405     const U8 lowest = (U8) ARG(n);
19406     unsigned int i;
19407     U8 count = 0;
19408     U8 needed = 1U << PL_bitcount[ (U8) ~ FLAGS(n)];
19409
19410     PERL_ARGS_ASSERT_GET_ANYOFM_CONTENTS;
19411
19412     /* Starting with the lowest code point, any code point that ANDed with the
19413      * mask yields the lowest code point is in the set */
19414     for (i = lowest; i <= 0xFF; i++) {
19415         if ((i & FLAGS(n)) == ARG(n)) {
19416             cp_list = add_cp_to_invlist(cp_list, i);
19417             count++;
19418
19419             /* We know how many code points (a power of two) that are in the
19420              * set.  No use looking once we've got that number */
19421             if (count >= needed) break;
19422         }
19423     }
19424
19425     return cp_list;
19426 }
19427
19428 /*
19429  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
19430  */
19431 #ifdef DEBUGGING
19432
19433 static void
19434 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
19435 {
19436     int bit;
19437     int set=0;
19438
19439     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
19440
19441     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
19442         if (flags & (1<<bit)) {
19443             if (!set++ && lead)
19444                 Perl_re_printf( aTHX_  "%s",lead);
19445             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
19446         }
19447     }
19448     if (lead)  {
19449         if (set)
19450             Perl_re_printf( aTHX_  "\n");
19451         else
19452             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
19453     }
19454 }
19455
19456 static void
19457 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
19458 {
19459     int bit;
19460     int set=0;
19461     regex_charset cs;
19462
19463     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
19464
19465     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
19466         if (flags & (1<<bit)) {
19467             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
19468                 continue;
19469             }
19470             if (!set++ && lead)
19471                 Perl_re_printf( aTHX_  "%s",lead);
19472             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
19473         }
19474     }
19475     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
19476             if (!set++ && lead) {
19477                 Perl_re_printf( aTHX_  "%s",lead);
19478             }
19479             switch (cs) {
19480                 case REGEX_UNICODE_CHARSET:
19481                     Perl_re_printf( aTHX_  "UNICODE");
19482                     break;
19483                 case REGEX_LOCALE_CHARSET:
19484                     Perl_re_printf( aTHX_  "LOCALE");
19485                     break;
19486                 case REGEX_ASCII_RESTRICTED_CHARSET:
19487                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
19488                     break;
19489                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
19490                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
19491                     break;
19492                 default:
19493                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
19494                     break;
19495             }
19496     }
19497     if (lead)  {
19498         if (set)
19499             Perl_re_printf( aTHX_  "\n");
19500         else
19501             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
19502     }
19503 }
19504 #endif
19505
19506 void
19507 Perl_regdump(pTHX_ const regexp *r)
19508 {
19509 #ifdef DEBUGGING
19510     int i;
19511     SV * const sv = sv_newmortal();
19512     SV *dsv= sv_newmortal();
19513     RXi_GET_DECL(r,ri);
19514     GET_RE_DEBUG_FLAGS_DECL;
19515
19516     PERL_ARGS_ASSERT_REGDUMP;
19517
19518     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
19519
19520     /* Header fields of interest. */
19521     for (i = 0; i < 2; i++) {
19522         if (r->substrs->data[i].substr) {
19523             RE_PV_QUOTED_DECL(s, 0, dsv,
19524                             SvPVX_const(r->substrs->data[i].substr),
19525                             RE_SV_DUMPLEN(r->substrs->data[i].substr),
19526                             PL_dump_re_max_len);
19527             Perl_re_printf( aTHX_
19528                           "%s %s%s at %" IVdf "..%" UVuf " ",
19529                           i ? "floating" : "anchored",
19530                           s,
19531                           RE_SV_TAIL(r->substrs->data[i].substr),
19532                           (IV)r->substrs->data[i].min_offset,
19533                           (UV)r->substrs->data[i].max_offset);
19534         }
19535         else if (r->substrs->data[i].utf8_substr) {
19536             RE_PV_QUOTED_DECL(s, 1, dsv,
19537                             SvPVX_const(r->substrs->data[i].utf8_substr),
19538                             RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
19539                             30);
19540             Perl_re_printf( aTHX_
19541                           "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
19542                           i ? "floating" : "anchored",
19543                           s,
19544                           RE_SV_TAIL(r->substrs->data[i].utf8_substr),
19545                           (IV)r->substrs->data[i].min_offset,
19546                           (UV)r->substrs->data[i].max_offset);
19547         }
19548     }
19549
19550     if (r->check_substr || r->check_utf8)
19551         Perl_re_printf( aTHX_
19552                       (const char *)
19553                       (   r->check_substr == r->substrs->data[1].substr
19554                        && r->check_utf8   == r->substrs->data[1].utf8_substr
19555                        ? "(checking floating" : "(checking anchored"));
19556     if (r->intflags & PREGf_NOSCAN)
19557         Perl_re_printf( aTHX_  " noscan");
19558     if (r->extflags & RXf_CHECK_ALL)
19559         Perl_re_printf( aTHX_  " isall");
19560     if (r->check_substr || r->check_utf8)
19561         Perl_re_printf( aTHX_  ") ");
19562
19563     if (ri->regstclass) {
19564         regprop(r, sv, ri->regstclass, NULL, NULL);
19565         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
19566     }
19567     if (r->intflags & PREGf_ANCH) {
19568         Perl_re_printf( aTHX_  "anchored");
19569         if (r->intflags & PREGf_ANCH_MBOL)
19570             Perl_re_printf( aTHX_  "(MBOL)");
19571         if (r->intflags & PREGf_ANCH_SBOL)
19572             Perl_re_printf( aTHX_  "(SBOL)");
19573         if (r->intflags & PREGf_ANCH_GPOS)
19574             Perl_re_printf( aTHX_  "(GPOS)");
19575         Perl_re_printf( aTHX_ " ");
19576     }
19577     if (r->intflags & PREGf_GPOS_SEEN)
19578         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
19579     if (r->intflags & PREGf_SKIP)
19580         Perl_re_printf( aTHX_  "plus ");
19581     if (r->intflags & PREGf_IMPLICIT)
19582         Perl_re_printf( aTHX_  "implicit ");
19583     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
19584     if (r->extflags & RXf_EVAL_SEEN)
19585         Perl_re_printf( aTHX_  "with eval ");
19586     Perl_re_printf( aTHX_  "\n");
19587     DEBUG_FLAGS_r({
19588         regdump_extflags("r->extflags: ",r->extflags);
19589         regdump_intflags("r->intflags: ",r->intflags);
19590     });
19591 #else
19592     PERL_ARGS_ASSERT_REGDUMP;
19593     PERL_UNUSED_CONTEXT;
19594     PERL_UNUSED_ARG(r);
19595 #endif  /* DEBUGGING */
19596 }
19597
19598 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
19599 #ifdef DEBUGGING
19600
19601 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
19602      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
19603      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
19604      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
19605      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
19606      || _CC_VERTSPACE != 15
19607 #   error Need to adjust order of anyofs[]
19608 #  endif
19609 static const char * const anyofs[] = {
19610     "\\w",
19611     "\\W",
19612     "\\d",
19613     "\\D",
19614     "[:alpha:]",
19615     "[:^alpha:]",
19616     "[:lower:]",
19617     "[:^lower:]",
19618     "[:upper:]",
19619     "[:^upper:]",
19620     "[:punct:]",
19621     "[:^punct:]",
19622     "[:print:]",
19623     "[:^print:]",
19624     "[:alnum:]",
19625     "[:^alnum:]",
19626     "[:graph:]",
19627     "[:^graph:]",
19628     "[:cased:]",
19629     "[:^cased:]",
19630     "\\s",
19631     "\\S",
19632     "[:blank:]",
19633     "[:^blank:]",
19634     "[:xdigit:]",
19635     "[:^xdigit:]",
19636     "[:cntrl:]",
19637     "[:^cntrl:]",
19638     "[:ascii:]",
19639     "[:^ascii:]",
19640     "\\v",
19641     "\\V"
19642 };
19643 #endif
19644
19645 /*
19646 - regprop - printable representation of opcode, with run time support
19647 */
19648
19649 void
19650 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
19651 {
19652 #ifdef DEBUGGING
19653     int k;
19654     RXi_GET_DECL(prog,progi);
19655     GET_RE_DEBUG_FLAGS_DECL;
19656
19657     PERL_ARGS_ASSERT_REGPROP;
19658
19659     SvPVCLEAR(sv);
19660
19661     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
19662         /* It would be nice to FAIL() here, but this may be called from
19663            regexec.c, and it would be hard to supply pRExC_state. */
19664         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19665                                               (int)OP(o), (int)REGNODE_MAX);
19666     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
19667
19668     k = PL_regkind[OP(o)];
19669
19670     if (k == EXACT) {
19671         sv_catpvs(sv, " ");
19672         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
19673          * is a crude hack but it may be the best for now since
19674          * we have no flag "this EXACTish node was UTF-8"
19675          * --jhi */
19676         pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len,
19677                   PL_colors[0], PL_colors[1],
19678                   PERL_PV_ESCAPE_UNI_DETECT |
19679                   PERL_PV_ESCAPE_NONASCII   |
19680                   PERL_PV_PRETTY_ELLIPSES   |
19681                   PERL_PV_PRETTY_LTGT       |
19682                   PERL_PV_PRETTY_NOCLEAR
19683                   );
19684     } else if (k == TRIE) {
19685         /* print the details of the trie in dumpuntil instead, as
19686          * progi->data isn't available here */
19687         const char op = OP(o);
19688         const U32 n = ARG(o);
19689         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
19690                (reg_ac_data *)progi->data->data[n] :
19691                NULL;
19692         const reg_trie_data * const trie
19693             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
19694
19695         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
19696         DEBUG_TRIE_COMPILE_r({
19697           if (trie->jump)
19698             sv_catpvs(sv, "(JUMP)");
19699           Perl_sv_catpvf(aTHX_ sv,
19700             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
19701             (UV)trie->startstate,
19702             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
19703             (UV)trie->wordcount,
19704             (UV)trie->minlen,
19705             (UV)trie->maxlen,
19706             (UV)TRIE_CHARCOUNT(trie),
19707             (UV)trie->uniquecharcount
19708           );
19709         });
19710         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
19711             sv_catpvs(sv, "[");
19712             (void) put_charclass_bitmap_innards(sv,
19713                                                 ((IS_ANYOF_TRIE(op))
19714                                                  ? ANYOF_BITMAP(o)
19715                                                  : TRIE_BITMAP(trie)),
19716                                                 NULL,
19717                                                 NULL,
19718                                                 NULL,
19719                                                 FALSE
19720                                                );
19721             sv_catpvs(sv, "]");
19722         }
19723     } else if (k == CURLY) {
19724         U32 lo = ARG1(o), hi = ARG2(o);
19725         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
19726             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
19727         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
19728         if (hi == REG_INFTY)
19729             sv_catpvs(sv, "INFTY");
19730         else
19731             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
19732         sv_catpvs(sv, "}");
19733     }
19734     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
19735         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
19736     else if (k == REF || k == OPEN || k == CLOSE
19737              || k == GROUPP || OP(o)==ACCEPT)
19738     {
19739         AV *name_list= NULL;
19740         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
19741         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
19742         if ( RXp_PAREN_NAMES(prog) ) {
19743             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19744         } else if ( pRExC_state ) {
19745             name_list= RExC_paren_name_list;
19746         }
19747         if (name_list) {
19748             if ( k != REF || (OP(o) < NREF)) {
19749                 SV **name= av_fetch(name_list, parno, 0 );
19750                 if (name)
19751                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19752             }
19753             else {
19754                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
19755                 I32 *nums=(I32*)SvPVX(sv_dat);
19756                 SV **name= av_fetch(name_list, nums[0], 0 );
19757                 I32 n;
19758                 if (name) {
19759                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
19760                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
19761                                     (n ? "," : ""), (IV)nums[n]);
19762                     }
19763                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19764                 }
19765             }
19766         }
19767         if ( k == REF && reginfo) {
19768             U32 n = ARG(o);  /* which paren pair */
19769             I32 ln = prog->offs[n].start;
19770             if (prog->lastparen < n || ln == -1 || prog->offs[n].end == -1)
19771                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
19772             else if (ln == prog->offs[n].end)
19773                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
19774             else {
19775                 const char *s = reginfo->strbeg + ln;
19776                 Perl_sv_catpvf(aTHX_ sv, ": ");
19777                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
19778                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
19779             }
19780         }
19781     } else if (k == GOSUB) {
19782         AV *name_list= NULL;
19783         if ( RXp_PAREN_NAMES(prog) ) {
19784             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19785         } else if ( pRExC_state ) {
19786             name_list= RExC_paren_name_list;
19787         }
19788
19789         /* Paren and offset */
19790         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
19791                 (int)((o + (int)ARG2L(o)) - progi->program) );
19792         if (name_list) {
19793             SV **name= av_fetch(name_list, ARG(o), 0 );
19794             if (name)
19795                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19796         }
19797     }
19798     else if (k == LOGICAL)
19799         /* 2: embedded, otherwise 1 */
19800         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
19801     else if (k == ANYOF) {
19802         const U8 flags = ANYOF_FLAGS(o);
19803         bool do_sep = FALSE;    /* Do we need to separate various components of
19804                                    the output? */
19805         /* Set if there is still an unresolved user-defined property */
19806         SV *unresolved                = NULL;
19807
19808         /* Things that are ignored except when the runtime locale is UTF-8 */
19809         SV *only_utf8_locale_invlist = NULL;
19810
19811         /* Code points that don't fit in the bitmap */
19812         SV *nonbitmap_invlist = NULL;
19813
19814         /* And things that aren't in the bitmap, but are small enough to be */
19815         SV* bitmap_range_not_in_bitmap = NULL;
19816
19817         const bool inverted = flags & ANYOF_INVERT;
19818
19819         if (OP(o) == ANYOFL) {
19820             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
19821                 sv_catpvs(sv, "{utf8-locale-reqd}");
19822             }
19823             if (flags & ANYOFL_FOLD) {
19824                 sv_catpvs(sv, "{i}");
19825             }
19826         }
19827
19828         /* If there is stuff outside the bitmap, get it */
19829         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
19830             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
19831                                                 &unresolved,
19832                                                 &only_utf8_locale_invlist,
19833                                                 &nonbitmap_invlist);
19834             /* The non-bitmap data may contain stuff that could fit in the
19835              * bitmap.  This could come from a user-defined property being
19836              * finally resolved when this call was done; or much more likely
19837              * because there are matches that require UTF-8 to be valid, and so
19838              * aren't in the bitmap.  This is teased apart later */
19839             _invlist_intersection(nonbitmap_invlist,
19840                                   PL_InBitmap,
19841                                   &bitmap_range_not_in_bitmap);
19842             /* Leave just the things that don't fit into the bitmap */
19843             _invlist_subtract(nonbitmap_invlist,
19844                               PL_InBitmap,
19845                               &nonbitmap_invlist);
19846         }
19847
19848         /* Obey this flag to add all above-the-bitmap code points */
19849         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
19850             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
19851                                                       NUM_ANYOF_CODE_POINTS,
19852                                                       UV_MAX);
19853         }
19854
19855         /* Ready to start outputting.  First, the initial left bracket */
19856         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19857
19858         /* Then all the things that could fit in the bitmap */
19859         do_sep = put_charclass_bitmap_innards(sv,
19860                                               ANYOF_BITMAP(o),
19861                                               bitmap_range_not_in_bitmap,
19862                                               only_utf8_locale_invlist,
19863                                               o,
19864
19865                                               /* Can't try inverting for a
19866                                                * better display if there are
19867                                                * things that haven't been
19868                                                * resolved */
19869                                               unresolved != NULL);
19870         SvREFCNT_dec(bitmap_range_not_in_bitmap);
19871
19872         /* If there are user-defined properties which haven't been defined yet,
19873          * output them.  If the result is not to be inverted, it is clearest to
19874          * output them in a separate [] from the bitmap range stuff.  If the
19875          * result is to be complemented, we have to show everything in one [],
19876          * as the inversion applies to the whole thing.  Use {braces} to
19877          * separate them from anything in the bitmap and anything above the
19878          * bitmap. */
19879         if (unresolved) {
19880             if (inverted) {
19881                 if (! do_sep) { /* If didn't output anything in the bitmap */
19882                     sv_catpvs(sv, "^");
19883                 }
19884                 sv_catpvs(sv, "{");
19885             }
19886             else if (do_sep) {
19887                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19888             }
19889             sv_catsv(sv, unresolved);
19890             if (inverted) {
19891                 sv_catpvs(sv, "}");
19892             }
19893             do_sep = ! inverted;
19894         }
19895
19896         /* And, finally, add the above-the-bitmap stuff */
19897         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
19898             SV* contents;
19899
19900             /* See if truncation size is overridden */
19901             const STRLEN dump_len = (PL_dump_re_max_len > 256)
19902                                     ? PL_dump_re_max_len
19903                                     : 256;
19904
19905             /* This is output in a separate [] */
19906             if (do_sep) {
19907                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19908             }
19909
19910             /* And, for easy of understanding, it is shown in the
19911              * uncomplemented form if possible.  The one exception being if
19912              * there are unresolved items, where the inversion has to be
19913              * delayed until runtime */
19914             if (inverted && ! unresolved) {
19915                 _invlist_invert(nonbitmap_invlist);
19916                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
19917             }
19918
19919             contents = invlist_contents(nonbitmap_invlist,
19920                                         FALSE /* output suitable for catsv */
19921                                        );
19922
19923             /* If the output is shorter than the permissible maximum, just do it. */
19924             if (SvCUR(contents) <= dump_len) {
19925                 sv_catsv(sv, contents);
19926             }
19927             else {
19928                 const char * contents_string = SvPVX(contents);
19929                 STRLEN i = dump_len;
19930
19931                 /* Otherwise, start at the permissible max and work back to the
19932                  * first break possibility */
19933                 while (i > 0 && contents_string[i] != ' ') {
19934                     i--;
19935                 }
19936                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
19937                                        find a legal break */
19938                     i = dump_len;
19939                 }
19940
19941                 sv_catpvn(sv, contents_string, i);
19942                 sv_catpvs(sv, "...");
19943             }
19944
19945             SvREFCNT_dec_NN(contents);
19946             SvREFCNT_dec_NN(nonbitmap_invlist);
19947         }
19948
19949         /* And finally the matching, closing ']' */
19950         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19951
19952         SvREFCNT_dec(unresolved);
19953     }
19954     else if (k == ANYOFM) {
19955         SV * cp_list = get_ANYOFM_contents(o);
19956
19957         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19958         put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, TRUE);
19959         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19960
19961         SvREFCNT_dec(cp_list);
19962     }
19963     else if (k == POSIXD || k == NPOSIXD) {
19964         U8 index = FLAGS(o) * 2;
19965         if (index < C_ARRAY_LENGTH(anyofs)) {
19966             if (*anyofs[index] != '[')  {
19967                 sv_catpv(sv, "[");
19968             }
19969             sv_catpv(sv, anyofs[index]);
19970             if (*anyofs[index] != '[')  {
19971                 sv_catpv(sv, "]");
19972             }
19973         }
19974         else {
19975             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
19976         }
19977     }
19978     else if (k == BOUND || k == NBOUND) {
19979         /* Must be synced with order of 'bound_type' in regcomp.h */
19980         const char * const bounds[] = {
19981             "",      /* Traditional */
19982             "{gcb}",
19983             "{lb}",
19984             "{sb}",
19985             "{wb}"
19986         };
19987         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
19988         sv_catpv(sv, bounds[FLAGS(o)]);
19989     }
19990     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
19991         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
19992     else if (OP(o) == SBOL)
19993         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
19994
19995     /* add on the verb argument if there is one */
19996     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
19997         if ( ARG(o) )
19998             Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
19999                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
20000         else
20001             sv_catpvs(sv, ":NULL");
20002     }
20003 #else
20004     PERL_UNUSED_CONTEXT;
20005     PERL_UNUSED_ARG(sv);
20006     PERL_UNUSED_ARG(o);
20007     PERL_UNUSED_ARG(prog);
20008     PERL_UNUSED_ARG(reginfo);
20009     PERL_UNUSED_ARG(pRExC_state);
20010 #endif  /* DEBUGGING */
20011 }
20012
20013
20014
20015 SV *
20016 Perl_re_intuit_string(pTHX_ REGEXP * const r)
20017 {                               /* Assume that RE_INTUIT is set */
20018     struct regexp *const prog = ReANY(r);
20019     GET_RE_DEBUG_FLAGS_DECL;
20020
20021     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
20022     PERL_UNUSED_CONTEXT;
20023
20024     DEBUG_COMPILE_r(
20025         {
20026             const char * const s = SvPV_nolen_const(RX_UTF8(r)
20027                       ? prog->check_utf8 : prog->check_substr);
20028
20029             if (!PL_colorset) reginitcolors();
20030             Perl_re_printf( aTHX_
20031                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
20032                       PL_colors[4],
20033                       RX_UTF8(r) ? "utf8 " : "",
20034                       PL_colors[5],PL_colors[0],
20035                       s,
20036                       PL_colors[1],
20037                       (strlen(s) > PL_dump_re_max_len ? "..." : ""));
20038         } );
20039
20040     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
20041     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
20042 }
20043
20044 /*
20045    pregfree()
20046
20047    handles refcounting and freeing the perl core regexp structure. When
20048    it is necessary to actually free the structure the first thing it
20049    does is call the 'free' method of the regexp_engine associated to
20050    the regexp, allowing the handling of the void *pprivate; member
20051    first. (This routine is not overridable by extensions, which is why
20052    the extensions free is called first.)
20053
20054    See regdupe and regdupe_internal if you change anything here.
20055 */
20056 #ifndef PERL_IN_XSUB_RE
20057 void
20058 Perl_pregfree(pTHX_ REGEXP *r)
20059 {
20060     SvREFCNT_dec(r);
20061 }
20062
20063 void
20064 Perl_pregfree2(pTHX_ REGEXP *rx)
20065 {
20066     struct regexp *const r = ReANY(rx);
20067     GET_RE_DEBUG_FLAGS_DECL;
20068
20069     PERL_ARGS_ASSERT_PREGFREE2;
20070
20071     if (r->mother_re) {
20072         ReREFCNT_dec(r->mother_re);
20073     } else {
20074         CALLREGFREE_PVT(rx); /* free the private data */
20075         SvREFCNT_dec(RXp_PAREN_NAMES(r));
20076     }
20077     if (r->substrs) {
20078         int i;
20079         for (i = 0; i < 2; i++) {
20080             SvREFCNT_dec(r->substrs->data[i].substr);
20081             SvREFCNT_dec(r->substrs->data[i].utf8_substr);
20082         }
20083         Safefree(r->substrs);
20084     }
20085     RX_MATCH_COPY_FREE(rx);
20086 #ifdef PERL_ANY_COW
20087     SvREFCNT_dec(r->saved_copy);
20088 #endif
20089     Safefree(r->offs);
20090     SvREFCNT_dec(r->qr_anoncv);
20091     if (r->recurse_locinput)
20092         Safefree(r->recurse_locinput);
20093 }
20094
20095
20096 /*  reg_temp_copy()
20097
20098     Copy ssv to dsv, both of which should of type SVt_REGEXP or SVt_PVLV,
20099     except that dsv will be created if NULL.
20100
20101     This function is used in two main ways. First to implement
20102         $r = qr/....; $s = $$r;
20103
20104     Secondly, it is used as a hacky workaround to the structural issue of
20105     match results
20106     being stored in the regexp structure which is in turn stored in
20107     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
20108     could be PL_curpm in multiple contexts, and could require multiple
20109     result sets being associated with the pattern simultaneously, such
20110     as when doing a recursive match with (??{$qr})
20111
20112     The solution is to make a lightweight copy of the regexp structure
20113     when a qr// is returned from the code executed by (??{$qr}) this
20114     lightweight copy doesn't actually own any of its data except for
20115     the starp/end and the actual regexp structure itself.
20116
20117 */
20118
20119
20120 REGEXP *
20121 Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv)
20122 {
20123     struct regexp *drx;
20124     struct regexp *const srx = ReANY(ssv);
20125     const bool islv = dsv && SvTYPE(dsv) == SVt_PVLV;
20126
20127     PERL_ARGS_ASSERT_REG_TEMP_COPY;
20128
20129     if (!dsv)
20130         dsv = (REGEXP*) newSV_type(SVt_REGEXP);
20131     else {
20132         SvOK_off((SV *)dsv);
20133         if (islv) {
20134             /* For PVLVs, the head (sv_any) points to an XPVLV, while
20135              * the LV's xpvlenu_rx will point to a regexp body, which
20136              * we allocate here */
20137             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
20138             assert(!SvPVX(dsv));
20139             ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any;
20140             temp->sv_any = NULL;
20141             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
20142             SvREFCNT_dec_NN(temp);
20143             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
20144                ing below will not set it. */
20145             SvCUR_set(dsv, SvCUR(ssv));
20146         }
20147     }
20148     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
20149        sv_force_normal(sv) is called.  */
20150     SvFAKE_on(dsv);
20151     drx = ReANY(dsv);
20152
20153     SvFLAGS(dsv) |= SvFLAGS(ssv) & (SVf_POK|SVp_POK|SVf_UTF8);
20154     SvPV_set(dsv, RX_WRAPPED(ssv));
20155     /* We share the same string buffer as the original regexp, on which we
20156        hold a reference count, incremented when mother_re is set below.
20157        The string pointer is copied here, being part of the regexp struct.
20158      */
20159     memcpy(&(drx->xpv_cur), &(srx->xpv_cur),
20160            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
20161     if (!islv)
20162         SvLEN_set(dsv, 0);
20163     if (srx->offs) {
20164         const I32 npar = srx->nparens+1;
20165         Newx(drx->offs, npar, regexp_paren_pair);
20166         Copy(srx->offs, drx->offs, npar, regexp_paren_pair);
20167     }
20168     if (srx->substrs) {
20169         int i;
20170         Newx(drx->substrs, 1, struct reg_substr_data);
20171         StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
20172
20173         for (i = 0; i < 2; i++) {
20174             SvREFCNT_inc_void(drx->substrs->data[i].substr);
20175             SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr);
20176         }
20177
20178         /* check_substr and check_utf8, if non-NULL, point to either their
20179            anchored or float namesakes, and don't hold a second reference.  */
20180     }
20181     RX_MATCH_COPIED_off(dsv);
20182 #ifdef PERL_ANY_COW
20183     drx->saved_copy = NULL;
20184 #endif
20185     drx->mother_re = ReREFCNT_inc(srx->mother_re ? srx->mother_re : ssv);
20186     SvREFCNT_inc_void(drx->qr_anoncv);
20187     if (srx->recurse_locinput)
20188         Newx(drx->recurse_locinput,srx->nparens + 1,char *);
20189
20190     return dsv;
20191 }
20192 #endif
20193
20194
20195 /* regfree_internal()
20196
20197    Free the private data in a regexp. This is overloadable by
20198    extensions. Perl takes care of the regexp structure in pregfree(),
20199    this covers the *pprivate pointer which technically perl doesn't
20200    know about, however of course we have to handle the
20201    regexp_internal structure when no extension is in use.
20202
20203    Note this is called before freeing anything in the regexp
20204    structure.
20205  */
20206
20207 void
20208 Perl_regfree_internal(pTHX_ REGEXP * const rx)
20209 {
20210     struct regexp *const r = ReANY(rx);
20211     RXi_GET_DECL(r,ri);
20212     GET_RE_DEBUG_FLAGS_DECL;
20213
20214     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
20215
20216     DEBUG_COMPILE_r({
20217         if (!PL_colorset)
20218             reginitcolors();
20219         {
20220             SV *dsv= sv_newmortal();
20221             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
20222                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len);
20223             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
20224                 PL_colors[4],PL_colors[5],s);
20225         }
20226     });
20227 #ifdef RE_TRACK_PATTERN_OFFSETS
20228     if (ri->u.offsets)
20229         Safefree(ri->u.offsets);             /* 20010421 MJD */
20230 #endif
20231     if (ri->code_blocks)
20232         S_free_codeblocks(aTHX_ ri->code_blocks);
20233
20234     if (ri->data) {
20235         int n = ri->data->count;
20236
20237         while (--n >= 0) {
20238           /* If you add a ->what type here, update the comment in regcomp.h */
20239             switch (ri->data->what[n]) {
20240             case 'a':
20241             case 'r':
20242             case 's':
20243             case 'S':
20244             case 'u':
20245                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
20246                 break;
20247             case 'f':
20248                 Safefree(ri->data->data[n]);
20249                 break;
20250             case 'l':
20251             case 'L':
20252                 break;
20253             case 'T':
20254                 { /* Aho Corasick add-on structure for a trie node.
20255                      Used in stclass optimization only */
20256                     U32 refcount;
20257                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
20258 #ifdef USE_ITHREADS
20259                     dVAR;
20260 #endif
20261                     OP_REFCNT_LOCK;
20262                     refcount = --aho->refcount;
20263                     OP_REFCNT_UNLOCK;
20264                     if ( !refcount ) {
20265                         PerlMemShared_free(aho->states);
20266                         PerlMemShared_free(aho->fail);
20267                          /* do this last!!!! */
20268                         PerlMemShared_free(ri->data->data[n]);
20269                         /* we should only ever get called once, so
20270                          * assert as much, and also guard the free
20271                          * which /might/ happen twice. At the least
20272                          * it will make code anlyzers happy and it
20273                          * doesn't cost much. - Yves */
20274                         assert(ri->regstclass);
20275                         if (ri->regstclass) {
20276                             PerlMemShared_free(ri->regstclass);
20277                             ri->regstclass = 0;
20278                         }
20279                     }
20280                 }
20281                 break;
20282             case 't':
20283                 {
20284                     /* trie structure. */
20285                     U32 refcount;
20286                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
20287 #ifdef USE_ITHREADS
20288                     dVAR;
20289 #endif
20290                     OP_REFCNT_LOCK;
20291                     refcount = --trie->refcount;
20292                     OP_REFCNT_UNLOCK;
20293                     if ( !refcount ) {
20294                         PerlMemShared_free(trie->charmap);
20295                         PerlMemShared_free(trie->states);
20296                         PerlMemShared_free(trie->trans);
20297                         if (trie->bitmap)
20298                             PerlMemShared_free(trie->bitmap);
20299                         if (trie->jump)
20300                             PerlMemShared_free(trie->jump);
20301                         PerlMemShared_free(trie->wordinfo);
20302                         /* do this last!!!! */
20303                         PerlMemShared_free(ri->data->data[n]);
20304                     }
20305                 }
20306                 break;
20307             default:
20308                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
20309                                                     ri->data->what[n]);
20310             }
20311         }
20312         Safefree(ri->data->what);
20313         Safefree(ri->data);
20314     }
20315
20316     Safefree(ri);
20317 }
20318
20319 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
20320 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
20321 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
20322
20323 /*
20324    re_dup_guts - duplicate a regexp.
20325
20326    This routine is expected to clone a given regexp structure. It is only
20327    compiled under USE_ITHREADS.
20328
20329    After all of the core data stored in struct regexp is duplicated
20330    the regexp_engine.dupe method is used to copy any private data
20331    stored in the *pprivate pointer. This allows extensions to handle
20332    any duplication it needs to do.
20333
20334    See pregfree() and regfree_internal() if you change anything here.
20335 */
20336 #if defined(USE_ITHREADS)
20337 #ifndef PERL_IN_XSUB_RE
20338 void
20339 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
20340 {
20341     dVAR;
20342     I32 npar;
20343     const struct regexp *r = ReANY(sstr);
20344     struct regexp *ret = ReANY(dstr);
20345
20346     PERL_ARGS_ASSERT_RE_DUP_GUTS;
20347
20348     npar = r->nparens+1;
20349     Newx(ret->offs, npar, regexp_paren_pair);
20350     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
20351
20352     if (ret->substrs) {
20353         /* Do it this way to avoid reading from *r after the StructCopy().
20354            That way, if any of the sv_dup_inc()s dislodge *r from the L1
20355            cache, it doesn't matter.  */
20356         int i;
20357         const bool anchored = r->check_substr
20358             ? r->check_substr == r->substrs->data[0].substr
20359             : r->check_utf8   == r->substrs->data[0].utf8_substr;
20360         Newx(ret->substrs, 1, struct reg_substr_data);
20361         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
20362
20363         for (i = 0; i < 2; i++) {
20364             ret->substrs->data[i].substr =
20365                         sv_dup_inc(ret->substrs->data[i].substr, param);
20366             ret->substrs->data[i].utf8_substr =
20367                         sv_dup_inc(ret->substrs->data[i].utf8_substr, param);
20368         }
20369
20370         /* check_substr and check_utf8, if non-NULL, point to either their
20371            anchored or float namesakes, and don't hold a second reference.  */
20372
20373         if (ret->check_substr) {
20374             if (anchored) {
20375                 assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
20376
20377                 ret->check_substr = ret->substrs->data[0].substr;
20378                 ret->check_utf8   = ret->substrs->data[0].utf8_substr;
20379             } else {
20380                 assert(r->check_substr == r->substrs->data[1].substr);
20381                 assert(r->check_utf8   == r->substrs->data[1].utf8_substr);
20382
20383                 ret->check_substr = ret->substrs->data[1].substr;
20384                 ret->check_utf8   = ret->substrs->data[1].utf8_substr;
20385             }
20386         } else if (ret->check_utf8) {
20387             if (anchored) {
20388                 ret->check_utf8 = ret->substrs->data[0].utf8_substr;
20389             } else {
20390                 ret->check_utf8 = ret->substrs->data[1].utf8_substr;
20391             }
20392         }
20393     }
20394
20395     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
20396     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
20397     if (r->recurse_locinput)
20398         Newx(ret->recurse_locinput,r->nparens + 1,char *);
20399
20400     if (ret->pprivate)
20401         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
20402
20403     if (RX_MATCH_COPIED(dstr))
20404         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
20405     else
20406         ret->subbeg = NULL;
20407 #ifdef PERL_ANY_COW
20408     ret->saved_copy = NULL;
20409 #endif
20410
20411     /* Whether mother_re be set or no, we need to copy the string.  We
20412        cannot refrain from copying it when the storage points directly to
20413        our mother regexp, because that's
20414                1: a buffer in a different thread
20415                2: something we no longer hold a reference on
20416                so we need to copy it locally.  */
20417     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
20418     ret->mother_re   = NULL;
20419 }
20420 #endif /* PERL_IN_XSUB_RE */
20421
20422 /*
20423    regdupe_internal()
20424
20425    This is the internal complement to regdupe() which is used to copy
20426    the structure pointed to by the *pprivate pointer in the regexp.
20427    This is the core version of the extension overridable cloning hook.
20428    The regexp structure being duplicated will be copied by perl prior
20429    to this and will be provided as the regexp *r argument, however
20430    with the /old/ structures pprivate pointer value. Thus this routine
20431    may override any copying normally done by perl.
20432
20433    It returns a pointer to the new regexp_internal structure.
20434 */
20435
20436 void *
20437 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
20438 {
20439     dVAR;
20440     struct regexp *const r = ReANY(rx);
20441     regexp_internal *reti;
20442     int len;
20443     RXi_GET_DECL(r,ri);
20444
20445     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
20446
20447     len = ProgLen(ri);
20448
20449     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
20450           char, regexp_internal);
20451     Copy(ri->program, reti->program, len+1, regnode);
20452
20453
20454     if (ri->code_blocks) {
20455         int n;
20456         Newx(reti->code_blocks, 1, struct reg_code_blocks);
20457         Newx(reti->code_blocks->cb, ri->code_blocks->count,
20458                     struct reg_code_block);
20459         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
20460              ri->code_blocks->count, struct reg_code_block);
20461         for (n = 0; n < ri->code_blocks->count; n++)
20462              reti->code_blocks->cb[n].src_regex = (REGEXP*)
20463                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
20464         reti->code_blocks->count = ri->code_blocks->count;
20465         reti->code_blocks->refcnt = 1;
20466     }
20467     else
20468         reti->code_blocks = NULL;
20469
20470     reti->regstclass = NULL;
20471
20472     if (ri->data) {
20473         struct reg_data *d;
20474         const int count = ri->data->count;
20475         int i;
20476
20477         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
20478                 char, struct reg_data);
20479         Newx(d->what, count, U8);
20480
20481         d->count = count;
20482         for (i = 0; i < count; i++) {
20483             d->what[i] = ri->data->what[i];
20484             switch (d->what[i]) {
20485                 /* see also regcomp.h and regfree_internal() */
20486             case 'a': /* actually an AV, but the dup function is identical.
20487                          values seem to be "plain sv's" generally. */
20488             case 'r': /* a compiled regex (but still just another SV) */
20489             case 's': /* an RV (currently only used for an RV to an AV by the ANYOF code)
20490                          this use case should go away, the code could have used
20491                          'a' instead - see S_set_ANYOF_arg() for array contents. */
20492             case 'S': /* actually an SV, but the dup function is identical.  */
20493             case 'u': /* actually an HV, but the dup function is identical.
20494                          values are "plain sv's" */
20495                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
20496                 break;
20497             case 'f':
20498                 /* Synthetic Start Class - "Fake" charclass we generate to optimize
20499                  * patterns which could start with several different things. Pre-TRIE
20500                  * this was more important than it is now, however this still helps
20501                  * in some places, for instance /x?a+/ might produce a SSC equivalent
20502                  * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass()
20503                  * in regexec.c
20504                  */
20505                 /* This is cheating. */
20506                 Newx(d->data[i], 1, regnode_ssc);
20507                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
20508                 reti->regstclass = (regnode*)d->data[i];
20509                 break;
20510             case 'T':
20511                 /* AHO-CORASICK fail table */
20512                 /* Trie stclasses are readonly and can thus be shared
20513                  * without duplication. We free the stclass in pregfree
20514                  * when the corresponding reg_ac_data struct is freed.
20515                  */
20516                 reti->regstclass= ri->regstclass;
20517                 /* FALLTHROUGH */
20518             case 't':
20519                 /* TRIE transition table */
20520                 OP_REFCNT_LOCK;
20521                 ((reg_trie_data*)ri->data->data[i])->refcount++;
20522                 OP_REFCNT_UNLOCK;
20523                 /* FALLTHROUGH */
20524             case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */
20525             case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code
20526                          is not from another regexp */
20527                 d->data[i] = ri->data->data[i];
20528                 break;
20529             default:
20530                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
20531                                                            ri->data->what[i]);
20532             }
20533         }
20534
20535         reti->data = d;
20536     }
20537     else
20538         reti->data = NULL;
20539
20540     reti->name_list_idx = ri->name_list_idx;
20541
20542 #ifdef RE_TRACK_PATTERN_OFFSETS
20543     if (ri->u.offsets) {
20544         Newx(reti->u.offsets, 2*len+1, U32);
20545         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
20546     }
20547 #else
20548     SetProgLen(reti,len);
20549 #endif
20550
20551     return (void*)reti;
20552 }
20553
20554 #endif    /* USE_ITHREADS */
20555
20556 #ifndef PERL_IN_XSUB_RE
20557
20558 /*
20559  - regnext - dig the "next" pointer out of a node
20560  */
20561 regnode *
20562 Perl_regnext(pTHX_ regnode *p)
20563 {
20564     I32 offset;
20565
20566     if (!p)
20567         return(NULL);
20568
20569     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
20570         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
20571                                                 (int)OP(p), (int)REGNODE_MAX);
20572     }
20573
20574     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
20575     if (offset == 0)
20576         return(NULL);
20577
20578     return(p+offset);
20579 }
20580 #endif
20581
20582 STATIC void
20583 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
20584 {
20585     va_list args;
20586     STRLEN l1 = strlen(pat1);
20587     STRLEN l2 = strlen(pat2);
20588     char buf[512];
20589     SV *msv;
20590     const char *message;
20591
20592     PERL_ARGS_ASSERT_RE_CROAK2;
20593
20594     if (l1 > 510)
20595         l1 = 510;
20596     if (l1 + l2 > 510)
20597         l2 = 510 - l1;
20598     Copy(pat1, buf, l1 , char);
20599     Copy(pat2, buf + l1, l2 , char);
20600     buf[l1 + l2] = '\n';
20601     buf[l1 + l2 + 1] = '\0';
20602     va_start(args, pat2);
20603     msv = vmess(buf, &args);
20604     va_end(args);
20605     message = SvPV_const(msv,l1);
20606     if (l1 > 512)
20607         l1 = 512;
20608     Copy(message, buf, l1 , char);
20609     /* l1-1 to avoid \n */
20610     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
20611 }
20612
20613 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
20614
20615 #ifndef PERL_IN_XSUB_RE
20616 void
20617 Perl_save_re_context(pTHX)
20618 {
20619     I32 nparens = -1;
20620     I32 i;
20621
20622     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
20623
20624     if (PL_curpm) {
20625         const REGEXP * const rx = PM_GETRE(PL_curpm);
20626         if (rx)
20627             nparens = RX_NPARENS(rx);
20628     }
20629
20630     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
20631      * that PL_curpm will be null, but that utf8.pm and the modules it
20632      * loads will only use $1..$3.
20633      * The t/porting/re_context.t test file checks this assumption.
20634      */
20635     if (nparens == -1)
20636         nparens = 3;
20637
20638     for (i = 1; i <= nparens; i++) {
20639         char digits[TYPE_CHARS(long)];
20640         const STRLEN len = my_snprintf(digits, sizeof(digits),
20641                                        "%lu", (long)i);
20642         GV *const *const gvp
20643             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
20644
20645         if (gvp) {
20646             GV * const gv = *gvp;
20647             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
20648                 save_scalar(gv);
20649         }
20650     }
20651 }
20652 #endif
20653
20654 #ifdef DEBUGGING
20655
20656 STATIC void
20657 S_put_code_point(pTHX_ SV *sv, UV c)
20658 {
20659     PERL_ARGS_ASSERT_PUT_CODE_POINT;
20660
20661     if (c > 255) {
20662         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
20663     }
20664     else if (isPRINT(c)) {
20665         const char string = (char) c;
20666
20667         /* We use {phrase} as metanotation in the class, so also escape literal
20668          * braces */
20669         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
20670             sv_catpvs(sv, "\\");
20671         sv_catpvn(sv, &string, 1);
20672     }
20673     else if (isMNEMONIC_CNTRL(c)) {
20674         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
20675     }
20676     else {
20677         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
20678     }
20679 }
20680
20681 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
20682
20683 STATIC void
20684 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
20685 {
20686     /* Appends to 'sv' a displayable version of the range of code points from
20687      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
20688      * that have them, when they occur at the beginning or end of the range.
20689      * It uses hex to output the remaining code points, unless 'allow_literals'
20690      * is true, in which case the printable ASCII ones are output as-is (though
20691      * some of these will be escaped by put_code_point()).
20692      *
20693      * NOTE:  This is designed only for printing ranges of code points that fit
20694      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
20695      */
20696
20697     const unsigned int min_range_count = 3;
20698
20699     assert(start <= end);
20700
20701     PERL_ARGS_ASSERT_PUT_RANGE;
20702
20703     while (start <= end) {
20704         UV this_end;
20705         const char * format;
20706
20707         if (end - start < min_range_count) {
20708
20709             /* Output chars individually when they occur in short ranges */
20710             for (; start <= end; start++) {
20711                 put_code_point(sv, start);
20712             }
20713             break;
20714         }
20715
20716         /* If permitted by the input options, and there is a possibility that
20717          * this range contains a printable literal, look to see if there is
20718          * one. */
20719         if (allow_literals && start <= MAX_PRINT_A) {
20720
20721             /* If the character at the beginning of the range isn't an ASCII
20722              * printable, effectively split the range into two parts:
20723              *  1) the portion before the first such printable,
20724              *  2) the rest
20725              * and output them separately. */
20726             if (! isPRINT_A(start)) {
20727                 UV temp_end = start + 1;
20728
20729                 /* There is no point looking beyond the final possible
20730                  * printable, in MAX_PRINT_A */
20731                 UV max = MIN(end, MAX_PRINT_A);
20732
20733                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
20734                     temp_end++;
20735                 }
20736
20737                 /* Here, temp_end points to one beyond the first printable if
20738                  * found, or to one beyond 'max' if not.  If none found, make
20739                  * sure that we use the entire range */
20740                 if (temp_end > MAX_PRINT_A) {
20741                     temp_end = end + 1;
20742                 }
20743
20744                 /* Output the first part of the split range: the part that
20745                  * doesn't have printables, with the parameter set to not look
20746                  * for literals (otherwise we would infinitely recurse) */
20747                 put_range(sv, start, temp_end - 1, FALSE);
20748
20749                 /* The 2nd part of the range (if any) starts here. */
20750                 start = temp_end;
20751
20752                 /* We do a continue, instead of dropping down, because even if
20753                  * the 2nd part is non-empty, it could be so short that we want
20754                  * to output it as individual characters, as tested for at the
20755                  * top of this loop.  */
20756                 continue;
20757             }
20758
20759             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
20760              * output a sub-range of just the digits or letters, then process
20761              * the remaining portion as usual. */
20762             if (isALPHANUMERIC_A(start)) {
20763                 UV mask = (isDIGIT_A(start))
20764                            ? _CC_DIGIT
20765                              : isUPPER_A(start)
20766                                ? _CC_UPPER
20767                                : _CC_LOWER;
20768                 UV temp_end = start + 1;
20769
20770                 /* Find the end of the sub-range that includes just the
20771                  * characters in the same class as the first character in it */
20772                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
20773                     temp_end++;
20774                 }
20775                 temp_end--;
20776
20777                 /* For short ranges, don't duplicate the code above to output
20778                  * them; just call recursively */
20779                 if (temp_end - start < min_range_count) {
20780                     put_range(sv, start, temp_end, FALSE);
20781                 }
20782                 else {  /* Output as a range */
20783                     put_code_point(sv, start);
20784                     sv_catpvs(sv, "-");
20785                     put_code_point(sv, temp_end);
20786                 }
20787                 start = temp_end + 1;
20788                 continue;
20789             }
20790
20791             /* We output any other printables as individual characters */
20792             if (isPUNCT_A(start) || isSPACE_A(start)) {
20793                 while (start <= end && (isPUNCT_A(start)
20794                                         || isSPACE_A(start)))
20795                 {
20796                     put_code_point(sv, start);
20797                     start++;
20798                 }
20799                 continue;
20800             }
20801         } /* End of looking for literals */
20802
20803         /* Here is not to output as a literal.  Some control characters have
20804          * mnemonic names.  Split off any of those at the beginning and end of
20805          * the range to print mnemonically.  It isn't possible for many of
20806          * these to be in a row, so this won't overwhelm with output */
20807         if (   start <= end
20808             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
20809         {
20810             while (isMNEMONIC_CNTRL(start) && start <= end) {
20811                 put_code_point(sv, start);
20812                 start++;
20813             }
20814
20815             /* If this didn't take care of the whole range ... */
20816             if (start <= end) {
20817
20818                 /* Look backwards from the end to find the final non-mnemonic
20819                  * */
20820                 UV temp_end = end;
20821                 while (isMNEMONIC_CNTRL(temp_end)) {
20822                     temp_end--;
20823                 }
20824
20825                 /* And separately output the interior range that doesn't start
20826                  * or end with mnemonics */
20827                 put_range(sv, start, temp_end, FALSE);
20828
20829                 /* Then output the mnemonic trailing controls */
20830                 start = temp_end + 1;
20831                 while (start <= end) {
20832                     put_code_point(sv, start);
20833                     start++;
20834                 }
20835                 break;
20836             }
20837         }
20838
20839         /* As a final resort, output the range or subrange as hex. */
20840
20841         this_end = (end < NUM_ANYOF_CODE_POINTS)
20842                     ? end
20843                     : NUM_ANYOF_CODE_POINTS - 1;
20844 #if NUM_ANYOF_CODE_POINTS > 256
20845         format = (this_end < 256)
20846                  ? "\\x%02" UVXf "-\\x%02" UVXf
20847                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
20848 #else
20849         format = "\\x%02" UVXf "-\\x%02" UVXf;
20850 #endif
20851         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
20852         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
20853         GCC_DIAG_RESTORE_STMT;
20854         break;
20855     }
20856 }
20857
20858 STATIC void
20859 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
20860 {
20861     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
20862      * 'invlist' */
20863
20864     UV start, end;
20865     bool allow_literals = TRUE;
20866
20867     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
20868
20869     /* Generally, it is more readable if printable characters are output as
20870      * literals, but if a range (nearly) spans all of them, it's best to output
20871      * it as a single range.  This code will use a single range if all but 2
20872      * ASCII printables are in it */
20873     invlist_iterinit(invlist);
20874     while (invlist_iternext(invlist, &start, &end)) {
20875
20876         /* If the range starts beyond the final printable, it doesn't have any
20877          * in it */
20878         if (start > MAX_PRINT_A) {
20879             break;
20880         }
20881
20882         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
20883          * all but two, the range must start and end no later than 2 from
20884          * either end */
20885         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
20886             if (end > MAX_PRINT_A) {
20887                 end = MAX_PRINT_A;
20888             }
20889             if (start < ' ') {
20890                 start = ' ';
20891             }
20892             if (end - start >= MAX_PRINT_A - ' ' - 2) {
20893                 allow_literals = FALSE;
20894             }
20895             break;
20896         }
20897     }
20898     invlist_iterfinish(invlist);
20899
20900     /* Here we have figured things out.  Output each range */
20901     invlist_iterinit(invlist);
20902     while (invlist_iternext(invlist, &start, &end)) {
20903         if (start >= NUM_ANYOF_CODE_POINTS) {
20904             break;
20905         }
20906         put_range(sv, start, end, allow_literals);
20907     }
20908     invlist_iterfinish(invlist);
20909
20910     return;
20911 }
20912
20913 STATIC SV*
20914 S_put_charclass_bitmap_innards_common(pTHX_
20915         SV* invlist,            /* The bitmap */
20916         SV* posixes,            /* Under /l, things like [:word:], \S */
20917         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
20918         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
20919         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
20920         const bool invert       /* Is the result to be inverted? */
20921 )
20922 {
20923     /* Create and return an SV containing a displayable version of the bitmap
20924      * and associated information determined by the input parameters.  If the
20925      * output would have been only the inversion indicator '^', NULL is instead
20926      * returned. */
20927
20928     SV * output;
20929
20930     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
20931
20932     if (invert) {
20933         output = newSVpvs("^");
20934     }
20935     else {
20936         output = newSVpvs("");
20937     }
20938
20939     /* First, the code points in the bitmap that are unconditionally there */
20940     put_charclass_bitmap_innards_invlist(output, invlist);
20941
20942     /* Traditionally, these have been placed after the main code points */
20943     if (posixes) {
20944         sv_catsv(output, posixes);
20945     }
20946
20947     if (only_utf8 && _invlist_len(only_utf8)) {
20948         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
20949         put_charclass_bitmap_innards_invlist(output, only_utf8);
20950     }
20951
20952     if (not_utf8 && _invlist_len(not_utf8)) {
20953         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
20954         put_charclass_bitmap_innards_invlist(output, not_utf8);
20955     }
20956
20957     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
20958         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
20959         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
20960
20961         /* This is the only list in this routine that can legally contain code
20962          * points outside the bitmap range.  The call just above to
20963          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
20964          * output them here.  There's about a half-dozen possible, and none in
20965          * contiguous ranges longer than 2 */
20966         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20967             UV start, end;
20968             SV* above_bitmap = NULL;
20969
20970             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
20971
20972             invlist_iterinit(above_bitmap);
20973             while (invlist_iternext(above_bitmap, &start, &end)) {
20974                 UV i;
20975
20976                 for (i = start; i <= end; i++) {
20977                     put_code_point(output, i);
20978                 }
20979             }
20980             invlist_iterfinish(above_bitmap);
20981             SvREFCNT_dec_NN(above_bitmap);
20982         }
20983     }
20984
20985     if (invert && SvCUR(output) == 1) {
20986         return NULL;
20987     }
20988
20989     return output;
20990 }
20991
20992 STATIC bool
20993 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
20994                                      char *bitmap,
20995                                      SV *nonbitmap_invlist,
20996                                      SV *only_utf8_locale_invlist,
20997                                      const regnode * const node,
20998                                      const bool force_as_is_display)
20999 {
21000     /* Appends to 'sv' a displayable version of the innards of the bracketed
21001      * character class defined by the other arguments:
21002      *  'bitmap' points to the bitmap, or NULL if to ignore that.
21003      *  'nonbitmap_invlist' is an inversion list of the code points that are in
21004      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
21005      *      none.  The reasons for this could be that they require some
21006      *      condition such as the target string being or not being in UTF-8
21007      *      (under /d), or because they came from a user-defined property that
21008      *      was not resolved at the time of the regex compilation (under /u)
21009      *  'only_utf8_locale_invlist' is an inversion list of the code points that
21010      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
21011      *  'node' is the regex pattern ANYOF node.  It is needed only when the
21012      *      above two parameters are not null, and is passed so that this
21013      *      routine can tease apart the various reasons for them.
21014      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
21015      *      to invert things to see if that leads to a cleaner display.  If
21016      *      FALSE, this routine is free to use its judgment about doing this.
21017      *
21018      * It returns TRUE if there was actually something output.  (It may be that
21019      * the bitmap, etc is empty.)
21020      *
21021      * When called for outputting the bitmap of a non-ANYOF node, just pass the
21022      * bitmap, with the succeeding parameters set to NULL, and the final one to
21023      * FALSE.
21024      */
21025
21026     /* In general, it tries to display the 'cleanest' representation of the
21027      * innards, choosing whether to display them inverted or not, regardless of
21028      * whether the class itself is to be inverted.  However,  there are some
21029      * cases where it can't try inverting, as what actually matches isn't known
21030      * until runtime, and hence the inversion isn't either. */
21031     bool inverting_allowed = ! force_as_is_display;
21032
21033     int i;
21034     STRLEN orig_sv_cur = SvCUR(sv);
21035
21036     SV* invlist;            /* Inversion list we accumulate of code points that
21037                                are unconditionally matched */
21038     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
21039                                UTF-8 */
21040     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
21041                              */
21042     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
21043     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
21044                                        is UTF-8 */
21045
21046     SV* as_is_display;      /* The output string when we take the inputs
21047                                literally */
21048     SV* inverted_display;   /* The output string when we invert the inputs */
21049
21050     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
21051
21052     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
21053                                                    to match? */
21054     /* We are biased in favor of displaying things without them being inverted,
21055      * as that is generally easier to understand */
21056     const int bias = 5;
21057
21058     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
21059
21060     /* Start off with whatever code points are passed in.  (We clone, so we
21061      * don't change the caller's list) */
21062     if (nonbitmap_invlist) {
21063         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
21064         invlist = invlist_clone(nonbitmap_invlist);
21065     }
21066     else {  /* Worst case size is every other code point is matched */
21067         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
21068     }
21069
21070     if (flags) {
21071         if (OP(node) == ANYOFD) {
21072
21073             /* This flag indicates that the code points below 0x100 in the
21074              * nonbitmap list are precisely the ones that match only when the
21075              * target is UTF-8 (they should all be non-ASCII). */
21076             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
21077             {
21078                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
21079                 _invlist_subtract(invlist, only_utf8, &invlist);
21080             }
21081
21082             /* And this flag for matching all non-ASCII 0xFF and below */
21083             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
21084             {
21085                 not_utf8 = invlist_clone(PL_UpperLatin1);
21086             }
21087         }
21088         else if (OP(node) == ANYOFL) {
21089
21090             /* If either of these flags are set, what matches isn't
21091              * determinable except during execution, so don't know enough here
21092              * to invert */
21093             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
21094                 inverting_allowed = FALSE;
21095             }
21096
21097             /* What the posix classes match also varies at runtime, so these
21098              * will be output symbolically. */
21099             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
21100                 int i;
21101
21102                 posixes = newSVpvs("");
21103                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
21104                     if (ANYOF_POSIXL_TEST(node,i)) {
21105                         sv_catpv(posixes, anyofs[i]);
21106                     }
21107                 }
21108             }
21109         }
21110     }
21111
21112     /* Accumulate the bit map into the unconditional match list */
21113     if (bitmap) {
21114         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
21115             if (BITMAP_TEST(bitmap, i)) {
21116                 int start = i++;
21117                 for (;
21118                      i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i);
21119                      i++)
21120                 { /* empty */ }
21121                 invlist = _add_range_to_invlist(invlist, start, i-1);
21122             }
21123         }
21124     }
21125
21126     /* Make sure that the conditional match lists don't have anything in them
21127      * that match unconditionally; otherwise the output is quite confusing.
21128      * This could happen if the code that populates these misses some
21129      * duplication. */
21130     if (only_utf8) {
21131         _invlist_subtract(only_utf8, invlist, &only_utf8);
21132     }
21133     if (not_utf8) {
21134         _invlist_subtract(not_utf8, invlist, &not_utf8);
21135     }
21136
21137     if (only_utf8_locale_invlist) {
21138
21139         /* Since this list is passed in, we have to make a copy before
21140          * modifying it */
21141         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
21142
21143         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
21144
21145         /* And, it can get really weird for us to try outputting an inverted
21146          * form of this list when it has things above the bitmap, so don't even
21147          * try */
21148         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
21149             inverting_allowed = FALSE;
21150         }
21151     }
21152
21153     /* Calculate what the output would be if we take the input as-is */
21154     as_is_display = put_charclass_bitmap_innards_common(invlist,
21155                                                     posixes,
21156                                                     only_utf8,
21157                                                     not_utf8,
21158                                                     only_utf8_locale,
21159                                                     invert);
21160
21161     /* If have to take the output as-is, just do that */
21162     if (! inverting_allowed) {
21163         if (as_is_display) {
21164             sv_catsv(sv, as_is_display);
21165             SvREFCNT_dec_NN(as_is_display);
21166         }
21167     }
21168     else { /* But otherwise, create the output again on the inverted input, and
21169               use whichever version is shorter */
21170
21171         int inverted_bias, as_is_bias;
21172
21173         /* We will apply our bias to whichever of the the results doesn't have
21174          * the '^' */
21175         if (invert) {
21176             invert = FALSE;
21177             as_is_bias = bias;
21178             inverted_bias = 0;
21179         }
21180         else {
21181             invert = TRUE;
21182             as_is_bias = 0;
21183             inverted_bias = bias;
21184         }
21185
21186         /* Now invert each of the lists that contribute to the output,
21187          * excluding from the result things outside the possible range */
21188
21189         /* For the unconditional inversion list, we have to add in all the
21190          * conditional code points, so that when inverted, they will be gone
21191          * from it */
21192         _invlist_union(only_utf8, invlist, &invlist);
21193         _invlist_union(not_utf8, invlist, &invlist);
21194         _invlist_union(only_utf8_locale, invlist, &invlist);
21195         _invlist_invert(invlist);
21196         _invlist_intersection(invlist, PL_InBitmap, &invlist);
21197
21198         if (only_utf8) {
21199             _invlist_invert(only_utf8);
21200             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
21201         }
21202         else if (not_utf8) {
21203
21204             /* If a code point matches iff the target string is not in UTF-8,
21205              * then complementing the result has it not match iff not in UTF-8,
21206              * which is the same thing as matching iff it is UTF-8. */
21207             only_utf8 = not_utf8;
21208             not_utf8 = NULL;
21209         }
21210
21211         if (only_utf8_locale) {
21212             _invlist_invert(only_utf8_locale);
21213             _invlist_intersection(only_utf8_locale,
21214                                   PL_InBitmap,
21215                                   &only_utf8_locale);
21216         }
21217
21218         inverted_display = put_charclass_bitmap_innards_common(
21219                                             invlist,
21220                                             posixes,
21221                                             only_utf8,
21222                                             not_utf8,
21223                                             only_utf8_locale, invert);
21224
21225         /* Use the shortest representation, taking into account our bias
21226          * against showing it inverted */
21227         if (   inverted_display
21228             && (   ! as_is_display
21229                 || (  SvCUR(inverted_display) + inverted_bias
21230                     < SvCUR(as_is_display)    + as_is_bias)))
21231         {
21232             sv_catsv(sv, inverted_display);
21233         }
21234         else if (as_is_display) {
21235             sv_catsv(sv, as_is_display);
21236         }
21237
21238         SvREFCNT_dec(as_is_display);
21239         SvREFCNT_dec(inverted_display);
21240     }
21241
21242     SvREFCNT_dec_NN(invlist);
21243     SvREFCNT_dec(only_utf8);
21244     SvREFCNT_dec(not_utf8);
21245     SvREFCNT_dec(posixes);
21246     SvREFCNT_dec(only_utf8_locale);
21247
21248     return SvCUR(sv) > orig_sv_cur;
21249 }
21250
21251 #define CLEAR_OPTSTART                                                       \
21252     if (optstart) STMT_START {                                               \
21253         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
21254                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
21255         optstart=NULL;                                                       \
21256     } STMT_END
21257
21258 #define DUMPUNTIL(b,e)                                                       \
21259                     CLEAR_OPTSTART;                                          \
21260                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
21261
21262 STATIC const regnode *
21263 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
21264             const regnode *last, const regnode *plast,
21265             SV* sv, I32 indent, U32 depth)
21266 {
21267     U8 op = PSEUDO;     /* Arbitrary non-END op. */
21268     const regnode *next;
21269     const regnode *optstart= NULL;
21270
21271     RXi_GET_DECL(r,ri);
21272     GET_RE_DEBUG_FLAGS_DECL;
21273
21274     PERL_ARGS_ASSERT_DUMPUNTIL;
21275
21276 #ifdef DEBUG_DUMPUNTIL
21277     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
21278         last ? last-start : 0,plast ? plast-start : 0);
21279 #endif
21280
21281     if (plast && plast < last)
21282         last= plast;
21283
21284     while (PL_regkind[op] != END && (!last || node < last)) {
21285         assert(node);
21286         /* While that wasn't END last time... */
21287         NODE_ALIGN(node);
21288         op = OP(node);
21289         if (op == CLOSE || op == SRCLOSE || op == WHILEM)
21290             indent--;
21291         next = regnext((regnode *)node);
21292
21293         /* Where, what. */
21294         if (OP(node) == OPTIMIZED) {
21295             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
21296                 optstart = node;
21297             else
21298                 goto after_print;
21299         } else
21300             CLEAR_OPTSTART;
21301
21302         regprop(r, sv, node, NULL, NULL);
21303         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
21304                       (int)(2*indent + 1), "", SvPVX_const(sv));
21305
21306         if (OP(node) != OPTIMIZED) {
21307             if (next == NULL)           /* Next ptr. */
21308                 Perl_re_printf( aTHX_  " (0)");
21309             else if (PL_regkind[(U8)op] == BRANCH
21310                      && PL_regkind[OP(next)] != BRANCH )
21311                 Perl_re_printf( aTHX_  " (FAIL)");
21312             else
21313                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
21314             Perl_re_printf( aTHX_ "\n");
21315         }
21316
21317       after_print:
21318         if (PL_regkind[(U8)op] == BRANCHJ) {
21319             assert(next);
21320             {
21321                 const regnode *nnode = (OP(next) == LONGJMP
21322                                        ? regnext((regnode *)next)
21323                                        : next);
21324                 if (last && nnode > last)
21325                     nnode = last;
21326                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
21327             }
21328         }
21329         else if (PL_regkind[(U8)op] == BRANCH) {
21330             assert(next);
21331             DUMPUNTIL(NEXTOPER(node), next);
21332         }
21333         else if ( PL_regkind[(U8)op]  == TRIE ) {
21334             const regnode *this_trie = node;
21335             const char op = OP(node);
21336             const U32 n = ARG(node);
21337             const reg_ac_data * const ac = op>=AHOCORASICK ?
21338                (reg_ac_data *)ri->data->data[n] :
21339                NULL;
21340             const reg_trie_data * const trie =
21341                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
21342 #ifdef DEBUGGING
21343             AV *const trie_words
21344                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
21345 #endif
21346             const regnode *nextbranch= NULL;
21347             I32 word_idx;
21348             SvPVCLEAR(sv);
21349             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
21350                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
21351
21352                 Perl_re_indentf( aTHX_  "%s ",
21353                     indent+3,
21354                     elem_ptr
21355                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
21356                                 SvCUR(*elem_ptr), PL_dump_re_max_len,
21357                                 PL_colors[0], PL_colors[1],
21358                                 (SvUTF8(*elem_ptr)
21359                                  ? PERL_PV_ESCAPE_UNI
21360                                  : 0)
21361                                 | PERL_PV_PRETTY_ELLIPSES
21362                                 | PERL_PV_PRETTY_LTGT
21363                             )
21364                     : "???"
21365                 );
21366                 if (trie->jump) {
21367                     U16 dist= trie->jump[word_idx+1];
21368                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
21369                                (UV)((dist ? this_trie + dist : next) - start));
21370                     if (dist) {
21371                         if (!nextbranch)
21372                             nextbranch= this_trie + trie->jump[0];
21373                         DUMPUNTIL(this_trie + dist, nextbranch);
21374                     }
21375                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
21376                         nextbranch= regnext((regnode *)nextbranch);
21377                 } else {
21378                     Perl_re_printf( aTHX_  "\n");
21379                 }
21380             }
21381             if (last && next > last)
21382                 node= last;
21383             else
21384                 node= next;
21385         }
21386         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
21387             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
21388                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
21389         }
21390         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
21391             assert(next);
21392             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
21393         }
21394         else if ( op == PLUS || op == STAR) {
21395             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
21396         }
21397         else if (PL_regkind[(U8)op] == ANYOF) {
21398             /* arglen 1 + class block */
21399             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
21400                           ? ANYOF_POSIXL_SKIP
21401                           : ANYOF_SKIP);
21402             node = NEXTOPER(node);
21403         }
21404         else if (PL_regkind[(U8)op] == EXACT) {
21405             /* Literal string, where present. */
21406             node += NODE_SZ_STR(node) - 1;
21407             node = NEXTOPER(node);
21408         }
21409         else {
21410             node = NEXTOPER(node);
21411             node += regarglen[(U8)op];
21412         }
21413         if (op == CURLYX || op == OPEN || op == SROPEN)
21414             indent++;
21415     }
21416     CLEAR_OPTSTART;
21417 #ifdef DEBUG_DUMPUNTIL
21418     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
21419 #endif
21420     return node;
21421 }
21422
21423 #endif  /* DEBUGGING */
21424
21425 /*
21426  * ex: set ts=8 sts=4 sw=4 et:
21427  */