]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5022000/orig/regcomp.c
Add support for perl 5.22.0
[perl/modules/re-engine-Hooks.git] / src / 5022000 / orig / 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_static.c"
90 #include "inline_invlist.c"
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 #ifndef MIN
105 #define MIN(a,b) ((a) < (b) ? (a) : (b))
106 #endif
107
108 /* this is a chain of data about sub patterns we are processing that
109    need to be handled separately/specially in study_chunk. Its so
110    we can simulate recursion without losing state.  */
111 struct scan_frame;
112 typedef struct scan_frame {
113     regnode *last_regnode;      /* last node to process in this frame */
114     regnode *next_regnode;      /* next node to process when last is reached */
115     U32 prev_recursed_depth;
116     I32 stopparen;              /* what stopparen do we use */
117     U32 is_top_frame;           /* what flags do we use? */
118
119     struct scan_frame *this_prev_frame; /* this previous frame */
120     struct scan_frame *prev_frame;      /* previous frame */
121     struct scan_frame *next_frame;      /* next frame */
122 } scan_frame;
123
124 /* Certain characters are output as a sequence with the first being a
125  * backslash. */
126 #define isBACKSLASHED_PUNCT(c)                                              \
127                     ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
128
129
130 struct RExC_state_t {
131     U32         flags;                  /* RXf_* are we folding, multilining? */
132     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
133     char        *precomp;               /* uncompiled string. */
134     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
135     regexp      *rx;                    /* perl core regexp structure */
136     regexp_internal     *rxi;           /* internal data for regexp object
137                                            pprivate field */
138     char        *start;                 /* Start of input for compile */
139     char        *end;                   /* End of input for compile */
140     char        *parse;                 /* Input-scan pointer. */
141     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
142     regnode     *emit_start;            /* Start of emitted-code area */
143     regnode     *emit_bound;            /* First regnode outside of the
144                                            allocated space */
145     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
146                                            implies compiling, so don't emit */
147     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
148                                            large enough for the largest
149                                            non-EXACTish node, so can use it as
150                                            scratch in pass1 */
151     I32         naughty;                /* How bad is this pattern? */
152     I32         sawback;                /* Did we see \1, ...? */
153     U32         seen;
154     SSize_t     size;                   /* Code size. */
155     I32                npar;            /* Capture buffer count, (OPEN) plus
156                                            one. ("par" 0 is the whole
157                                            pattern)*/
158     I32         nestroot;               /* root parens we are in - used by
159                                            accept */
160     I32         extralen;
161     I32         seen_zerolen;
162     regnode     **open_parens;          /* pointers to open parens */
163     regnode     **close_parens;         /* pointers to close parens */
164     regnode     *opend;                 /* END node in program */
165     I32         utf8;           /* whether the pattern is utf8 or not */
166     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
167                                 /* XXX use this for future optimisation of case
168                                  * where pattern must be upgraded to utf8. */
169     I32         uni_semantics;  /* If a d charset modifier should use unicode
170                                    rules, even if the pattern is not in
171                                    utf8 */
172     HV          *paren_names;           /* Paren names */
173
174     regnode     **recurse;              /* Recurse regops */
175     I32         recurse_count;          /* Number of recurse regops */
176     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
177                                            through */
178     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
179     I32         in_lookbehind;
180     I32         contains_locale;
181     I32         contains_i;
182     I32         override_recoding;
183 #ifdef EBCDIC
184     I32         recode_x_to_native;
185 #endif
186     I32         in_multi_char_class;
187     struct reg_code_block *code_blocks; /* positions of literal (?{})
188                                             within pattern */
189     int         num_code_blocks;        /* size of code_blocks[] */
190     int         code_index;             /* next code_blocks[] slot */
191     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
192     scan_frame *frame_head;
193     scan_frame *frame_last;
194     U32         frame_count;
195     U32         strict;
196 #ifdef ADD_TO_REGEXEC
197     char        *starttry;              /* -Dr: where regtry was called. */
198 #define RExC_starttry   (pRExC_state->starttry)
199 #endif
200     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
201 #ifdef DEBUGGING
202     const char  *lastparse;
203     I32         lastnum;
204     AV          *paren_name_list;       /* idx -> name */
205     U32         study_chunk_recursed_count;
206     SV          *mysv1;
207     SV          *mysv2;
208 #define RExC_lastparse  (pRExC_state->lastparse)
209 #define RExC_lastnum    (pRExC_state->lastnum)
210 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
211 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
212 #define RExC_mysv       (pRExC_state->mysv1)
213 #define RExC_mysv1      (pRExC_state->mysv1)
214 #define RExC_mysv2      (pRExC_state->mysv2)
215
216 #endif
217 };
218
219 #define RExC_flags      (pRExC_state->flags)
220 #define RExC_pm_flags   (pRExC_state->pm_flags)
221 #define RExC_precomp    (pRExC_state->precomp)
222 #define RExC_rx_sv      (pRExC_state->rx_sv)
223 #define RExC_rx         (pRExC_state->rx)
224 #define RExC_rxi        (pRExC_state->rxi)
225 #define RExC_start      (pRExC_state->start)
226 #define RExC_end        (pRExC_state->end)
227 #define RExC_parse      (pRExC_state->parse)
228 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
229 #ifdef RE_TRACK_PATTERN_OFFSETS
230 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
231                                                          others */
232 #endif
233 #define RExC_emit       (pRExC_state->emit)
234 #define RExC_emit_dummy (pRExC_state->emit_dummy)
235 #define RExC_emit_start (pRExC_state->emit_start)
236 #define RExC_emit_bound (pRExC_state->emit_bound)
237 #define RExC_sawback    (pRExC_state->sawback)
238 #define RExC_seen       (pRExC_state->seen)
239 #define RExC_size       (pRExC_state->size)
240 #define RExC_maxlen        (pRExC_state->maxlen)
241 #define RExC_npar       (pRExC_state->npar)
242 #define RExC_nestroot   (pRExC_state->nestroot)
243 #define RExC_extralen   (pRExC_state->extralen)
244 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
245 #define RExC_utf8       (pRExC_state->utf8)
246 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
247 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
248 #define RExC_open_parens        (pRExC_state->open_parens)
249 #define RExC_close_parens       (pRExC_state->close_parens)
250 #define RExC_opend      (pRExC_state->opend)
251 #define RExC_paren_names        (pRExC_state->paren_names)
252 #define RExC_recurse    (pRExC_state->recurse)
253 #define RExC_recurse_count      (pRExC_state->recurse_count)
254 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
255 #define RExC_study_chunk_recursed_bytes  \
256                                    (pRExC_state->study_chunk_recursed_bytes)
257 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
258 #define RExC_contains_locale    (pRExC_state->contains_locale)
259 #define RExC_contains_i (pRExC_state->contains_i)
260 #define RExC_override_recoding (pRExC_state->override_recoding)
261 #ifdef EBCDIC
262 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
263 #endif
264 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
265 #define RExC_frame_head (pRExC_state->frame_head)
266 #define RExC_frame_last (pRExC_state->frame_last)
267 #define RExC_frame_count (pRExC_state->frame_count)
268 #define RExC_strict (pRExC_state->strict)
269
270 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
271  * a flag to disable back-off on the fixed/floating substrings - if it's
272  * a high complexity pattern we assume the benefit of avoiding a full match
273  * is worth the cost of checking for the substrings even if they rarely help.
274  */
275 #define RExC_naughty    (pRExC_state->naughty)
276 #define TOO_NAUGHTY (10)
277 #define MARK_NAUGHTY(add) \
278     if (RExC_naughty < TOO_NAUGHTY) \
279         RExC_naughty += (add)
280 #define MARK_NAUGHTY_EXP(exp, add) \
281     if (RExC_naughty < TOO_NAUGHTY) \
282         RExC_naughty += RExC_naughty / (exp) + (add)
283
284 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
285 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
286         ((*s) == '{' && regcurly(s)))
287
288 /*
289  * Flags to be passed up and down.
290  */
291 #define WORST           0       /* Worst case. */
292 #define HASWIDTH        0x01    /* Known to match non-null strings. */
293
294 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
295  * character.  (There needs to be a case: in the switch statement in regexec.c
296  * for any node marked SIMPLE.)  Note that this is not the same thing as
297  * REGNODE_SIMPLE */
298 #define SIMPLE          0x02
299 #define SPSTART         0x04    /* Starts with * or + */
300 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
301 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
302 #define RESTART_UTF8    0x20    /* Restart, need to calcuate sizes as UTF-8 */
303
304 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
305
306 /* whether trie related optimizations are enabled */
307 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
308 #define TRIE_STUDY_OPT
309 #define FULL_TRIE_STUDY
310 #define TRIE_STCLASS
311 #endif
312
313
314
315 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
316 #define PBITVAL(paren) (1 << ((paren) & 7))
317 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
318 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
319 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
320
321 #define REQUIRE_UTF8    STMT_START {                                       \
322                                      if (!UTF) {                           \
323                                          *flagp = RESTART_UTF8;            \
324                                          return NULL;                      \
325                                      }                                     \
326                         } STMT_END
327
328 /* This converts the named class defined in regcomp.h to its equivalent class
329  * number defined in handy.h. */
330 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
331 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
332
333 #define _invlist_union_complement_2nd(a, b, output) \
334                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
335 #define _invlist_intersection_complement_2nd(a, b, output) \
336                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
337
338 /* About scan_data_t.
339
340   During optimisation we recurse through the regexp program performing
341   various inplace (keyhole style) optimisations. In addition study_chunk
342   and scan_commit populate this data structure with information about
343   what strings MUST appear in the pattern. We look for the longest
344   string that must appear at a fixed location, and we look for the
345   longest string that may appear at a floating location. So for instance
346   in the pattern:
347
348     /FOO[xX]A.*B[xX]BAR/
349
350   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
351   strings (because they follow a .* construct). study_chunk will identify
352   both FOO and BAR as being the longest fixed and floating strings respectively.
353
354   The strings can be composites, for instance
355
356      /(f)(o)(o)/
357
358   will result in a composite fixed substring 'foo'.
359
360   For each string some basic information is maintained:
361
362   - offset or min_offset
363     This is the position the string must appear at, or not before.
364     It also implicitly (when combined with minlenp) tells us how many
365     characters must match before the string we are searching for.
366     Likewise when combined with minlenp and the length of the string it
367     tells us how many characters must appear after the string we have
368     found.
369
370   - max_offset
371     Only used for floating strings. This is the rightmost point that
372     the string can appear at. If set to SSize_t_MAX it indicates that the
373     string can occur infinitely far to the right.
374
375   - minlenp
376     A pointer to the minimum number of characters of the pattern that the
377     string was found inside. This is important as in the case of positive
378     lookahead or positive lookbehind we can have multiple patterns
379     involved. Consider
380
381     /(?=FOO).*F/
382
383     The minimum length of the pattern overall is 3, the minimum length
384     of the lookahead part is 3, but the minimum length of the part that
385     will actually match is 1. So 'FOO's minimum length is 3, but the
386     minimum length for the F is 1. This is important as the minimum length
387     is used to determine offsets in front of and behind the string being
388     looked for.  Since strings can be composites this is the length of the
389     pattern at the time it was committed with a scan_commit. Note that
390     the length is calculated by study_chunk, so that the minimum lengths
391     are not known until the full pattern has been compiled, thus the
392     pointer to the value.
393
394   - lookbehind
395
396     In the case of lookbehind the string being searched for can be
397     offset past the start point of the final matching string.
398     If this value was just blithely removed from the min_offset it would
399     invalidate some of the calculations for how many chars must match
400     before or after (as they are derived from min_offset and minlen and
401     the length of the string being searched for).
402     When the final pattern is compiled and the data is moved from the
403     scan_data_t structure into the regexp structure the information
404     about lookbehind is factored in, with the information that would
405     have been lost precalculated in the end_shift field for the
406     associated string.
407
408   The fields pos_min and pos_delta are used to store the minimum offset
409   and the delta to the maximum offset at the current point in the pattern.
410
411 */
412
413 typedef struct scan_data_t {
414     /*I32 len_min;      unused */
415     /*I32 len_delta;    unused */
416     SSize_t pos_min;
417     SSize_t pos_delta;
418     SV *last_found;
419     SSize_t last_end;       /* min value, <0 unless valid. */
420     SSize_t last_start_min;
421     SSize_t last_start_max;
422     SV **longest;           /* Either &l_fixed, or &l_float. */
423     SV *longest_fixed;      /* longest fixed string found in pattern */
424     SSize_t offset_fixed;   /* offset where it starts */
425     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
426     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
427     SV *longest_float;      /* longest floating string found in pattern */
428     SSize_t offset_float_min; /* earliest point in string it can appear */
429     SSize_t offset_float_max; /* latest point in string it can appear */
430     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
431     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
432     I32 flags;
433     I32 whilem_c;
434     SSize_t *last_closep;
435     regnode_ssc *start_class;
436 } scan_data_t;
437
438 /*
439  * Forward declarations for pregcomp()'s friends.
440  */
441
442 static const scan_data_t zero_scan_data =
443   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
444
445 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
446 #define SF_BEFORE_SEOL          0x0001
447 #define SF_BEFORE_MEOL          0x0002
448 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
449 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
450
451 #define SF_FIX_SHIFT_EOL        (+2)
452 #define SF_FL_SHIFT_EOL         (+4)
453
454 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
455 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
456
457 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
458 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
459 #define SF_IS_INF               0x0040
460 #define SF_HAS_PAR              0x0080
461 #define SF_IN_PAR               0x0100
462 #define SF_HAS_EVAL             0x0200
463 #define SCF_DO_SUBSTR           0x0400
464 #define SCF_DO_STCLASS_AND      0x0800
465 #define SCF_DO_STCLASS_OR       0x1000
466 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
467 #define SCF_WHILEM_VISITED_POS  0x2000
468
469 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
470 #define SCF_SEEN_ACCEPT         0x8000
471 #define SCF_TRIE_DOING_RESTUDY 0x10000
472 #define SCF_IN_DEFINE          0x20000
473
474
475
476
477 #define UTF cBOOL(RExC_utf8)
478
479 /* The enums for all these are ordered so things work out correctly */
480 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
481 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
482                                                      == REGEX_DEPENDS_CHARSET)
483 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
484 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
485                                                      >= REGEX_UNICODE_CHARSET)
486 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
487                                             == REGEX_ASCII_RESTRICTED_CHARSET)
488 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
489                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
490 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
491                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
492
493 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
494
495 /* For programs that want to be strictly Unicode compatible by dying if any
496  * attempt is made to match a non-Unicode code point against a Unicode
497  * property.  */
498 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
499
500 #define OOB_NAMEDCLASS          -1
501
502 /* There is no code point that is out-of-bounds, so this is problematic.  But
503  * its only current use is to initialize a variable that is always set before
504  * looked at. */
505 #define OOB_UNICODE             0xDEADBEEF
506
507 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
508 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
509
510
511 /* length of regex to show in messages that don't mark a position within */
512 #define RegexLengthToShowInErrorMessages 127
513
514 /*
515  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
516  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
517  * op/pragma/warn/regcomp.
518  */
519 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
520 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
521
522 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
523                         " in m/%"UTF8f MARKER2 "%"UTF8f"/"
524
525 #define REPORT_LOCATION_ARGS(offset)            \
526                 UTF8fARG(UTF, offset, RExC_precomp), \
527                 UTF8fARG(UTF, RExC_end - RExC_precomp - offset, RExC_precomp + offset)
528
529 /* Used to point after bad bytes for an error message, but avoid skipping
530  * past a nul byte. */
531 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
532
533 /*
534  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
535  * arg. Show regex, up to a maximum length. If it's too long, chop and add
536  * "...".
537  */
538 #define _FAIL(code) STMT_START {                                        \
539     const char *ellipses = "";                                          \
540     IV len = RExC_end - RExC_precomp;                                   \
541                                                                         \
542     if (!SIZE_ONLY)                                                     \
543         SAVEFREESV(RExC_rx_sv);                                         \
544     if (len > RegexLengthToShowInErrorMessages) {                       \
545         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
546         len = RegexLengthToShowInErrorMessages - 10;                    \
547         ellipses = "...";                                               \
548     }                                                                   \
549     code;                                                               \
550 } STMT_END
551
552 #define FAIL(msg) _FAIL(                            \
553     Perl_croak(aTHX_ "%s in regex m/%"UTF8f"%s/",           \
554             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
555
556 #define FAIL2(msg,arg) _FAIL(                       \
557     Perl_croak(aTHX_ msg " in regex m/%"UTF8f"%s/",         \
558             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
559
560 /*
561  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
562  */
563 #define Simple_vFAIL(m) STMT_START {                                    \
564     const IV offset =                                                   \
565         (RExC_parse > RExC_end ? RExC_end : RExC_parse) - RExC_precomp; \
566     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
567             m, REPORT_LOCATION_ARGS(offset));   \
568 } STMT_END
569
570 /*
571  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
572  */
573 #define vFAIL(m) STMT_START {                           \
574     if (!SIZE_ONLY)                                     \
575         SAVEFREESV(RExC_rx_sv);                         \
576     Simple_vFAIL(m);                                    \
577 } STMT_END
578
579 /*
580  * Like Simple_vFAIL(), but accepts two arguments.
581  */
582 #define Simple_vFAIL2(m,a1) STMT_START {                        \
583     const IV offset = RExC_parse - RExC_precomp;                        \
584     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,                      \
585                       REPORT_LOCATION_ARGS(offset));    \
586 } STMT_END
587
588 /*
589  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
590  */
591 #define vFAIL2(m,a1) STMT_START {                       \
592     if (!SIZE_ONLY)                                     \
593         SAVEFREESV(RExC_rx_sv);                         \
594     Simple_vFAIL2(m, a1);                               \
595 } STMT_END
596
597
598 /*
599  * Like Simple_vFAIL(), but accepts three arguments.
600  */
601 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
602     const IV offset = RExC_parse - RExC_precomp;                \
603     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
604             REPORT_LOCATION_ARGS(offset));      \
605 } STMT_END
606
607 /*
608  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
609  */
610 #define vFAIL3(m,a1,a2) STMT_START {                    \
611     if (!SIZE_ONLY)                                     \
612         SAVEFREESV(RExC_rx_sv);                         \
613     Simple_vFAIL3(m, a1, a2);                           \
614 } STMT_END
615
616 /*
617  * Like Simple_vFAIL(), but accepts four arguments.
618  */
619 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
620     const IV offset = RExC_parse - RExC_precomp;                \
621     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,              \
622             REPORT_LOCATION_ARGS(offset));      \
623 } STMT_END
624
625 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
626     if (!SIZE_ONLY)                                     \
627         SAVEFREESV(RExC_rx_sv);                         \
628     Simple_vFAIL4(m, a1, a2, a3);                       \
629 } STMT_END
630
631 /* A specialized version of vFAIL2 that works with UTF8f */
632 #define vFAIL2utf8f(m, a1) STMT_START { \
633     const IV offset = RExC_parse - RExC_precomp;   \
634     if (!SIZE_ONLY)                                \
635         SAVEFREESV(RExC_rx_sv);                    \
636     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, \
637             REPORT_LOCATION_ARGS(offset));         \
638 } STMT_END
639
640 /* These have asserts in them because of [perl #122671] Many warnings in
641  * regcomp.c can occur twice.  If they get output in pass1 and later in that
642  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
643  * would get output again.  So they should be output in pass2, and these
644  * asserts make sure new warnings follow that paradigm. */
645
646 /* m is not necessarily a "literal string", in this macro */
647 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
648     const IV offset = loc - RExC_precomp;                               \
649     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
650             m, REPORT_LOCATION_ARGS(offset));       \
651 } STMT_END
652
653 #define ckWARNreg(loc,m) STMT_START {                                   \
654     const IV offset = loc - RExC_precomp;                               \
655     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
656             REPORT_LOCATION_ARGS(offset));              \
657 } STMT_END
658
659 #define vWARN(loc, m) STMT_START {                                      \
660     const IV offset = loc - RExC_precomp;                               \
661     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,        \
662             REPORT_LOCATION_ARGS(offset));              \
663 } STMT_END
664
665 #define vWARN_dep(loc, m) STMT_START {                                  \
666     const IV offset = loc - RExC_precomp;                               \
667     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION,    \
668             REPORT_LOCATION_ARGS(offset));              \
669 } STMT_END
670
671 #define ckWARNdep(loc,m) STMT_START {                                   \
672     const IV offset = loc - RExC_precomp;                               \
673     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),                  \
674             m REPORT_LOCATION,                                          \
675             REPORT_LOCATION_ARGS(offset));              \
676 } STMT_END
677
678 #define ckWARNregdep(loc,m) STMT_START {                                \
679     const IV offset = loc - RExC_precomp;                               \
680     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),    \
681             m REPORT_LOCATION,                                          \
682             REPORT_LOCATION_ARGS(offset));              \
683 } STMT_END
684
685 #define ckWARN2reg_d(loc,m, a1) STMT_START {                            \
686     const IV offset = loc - RExC_precomp;                               \
687     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),                      \
688             m REPORT_LOCATION,                                          \
689             a1, REPORT_LOCATION_ARGS(offset));  \
690 } STMT_END
691
692 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
693     const IV offset = loc - RExC_precomp;                               \
694     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
695             a1, REPORT_LOCATION_ARGS(offset));  \
696 } STMT_END
697
698 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
699     const IV offset = loc - RExC_precomp;                               \
700     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,                \
701             a1, a2, REPORT_LOCATION_ARGS(offset));      \
702 } STMT_END
703
704 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
705     const IV offset = loc - RExC_precomp;                               \
706     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
707             a1, a2, REPORT_LOCATION_ARGS(offset));      \
708 } STMT_END
709
710 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
711     const IV offset = loc - RExC_precomp;                               \
712     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,                \
713             a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
714 } STMT_END
715
716 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
717     const IV offset = loc - RExC_precomp;                               \
718     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
719             a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
720 } STMT_END
721
722 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
723     const IV offset = loc - RExC_precomp;                               \
724     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,                \
725             a1, a2, a3, a4, REPORT_LOCATION_ARGS(offset)); \
726 } STMT_END
727
728 /* Macros for recording node offsets.   20001227 mjd@plover.com
729  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
730  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
731  * Element 0 holds the number n.
732  * Position is 1 indexed.
733  */
734 #ifndef RE_TRACK_PATTERN_OFFSETS
735 #define Set_Node_Offset_To_R(node,byte)
736 #define Set_Node_Offset(node,byte)
737 #define Set_Cur_Node_Offset
738 #define Set_Node_Length_To_R(node,len)
739 #define Set_Node_Length(node,len)
740 #define Set_Node_Cur_Length(node,start)
741 #define Node_Offset(n)
742 #define Node_Length(n)
743 #define Set_Node_Offset_Length(node,offset,len)
744 #define ProgLen(ri) ri->u.proglen
745 #define SetProgLen(ri,x) ri->u.proglen = x
746 #else
747 #define ProgLen(ri) ri->u.offsets[0]
748 #define SetProgLen(ri,x) ri->u.offsets[0] = x
749 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
750     if (! SIZE_ONLY) {                                                  \
751         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
752                     __LINE__, (int)(node), (int)(byte)));               \
753         if((node) < 0) {                                                \
754             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
755                                          (int)(node));                  \
756         } else {                                                        \
757             RExC_offsets[2*(node)-1] = (byte);                          \
758         }                                                               \
759     }                                                                   \
760 } STMT_END
761
762 #define Set_Node_Offset(node,byte) \
763     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
764 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
765
766 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
767     if (! SIZE_ONLY) {                                                  \
768         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
769                 __LINE__, (int)(node), (int)(len)));                    \
770         if((node) < 0) {                                                \
771             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
772                                          (int)(node));                  \
773         } else {                                                        \
774             RExC_offsets[2*(node)] = (len);                             \
775         }                                                               \
776     }                                                                   \
777 } STMT_END
778
779 #define Set_Node_Length(node,len) \
780     Set_Node_Length_To_R((node)-RExC_emit_start, len)
781 #define Set_Node_Cur_Length(node, start)                \
782     Set_Node_Length(node, RExC_parse - start)
783
784 /* Get offsets and lengths */
785 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
786 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
787
788 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
789     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
790     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
791 } STMT_END
792 #endif
793
794 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
795 #define EXPERIMENTAL_INPLACESCAN
796 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
797
798 #define DEBUG_RExC_seen() \
799         DEBUG_OPTIMISE_MORE_r({                                             \
800             PerlIO_printf(Perl_debug_log,"RExC_seen: ");                    \
801                                                                             \
802             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
803                 PerlIO_printf(Perl_debug_log,"REG_ZERO_LEN_SEEN ");         \
804                                                                             \
805             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
806                 PerlIO_printf(Perl_debug_log,"REG_LOOKBEHIND_SEEN ");       \
807                                                                             \
808             if (RExC_seen & REG_GPOS_SEEN)                                  \
809                 PerlIO_printf(Perl_debug_log,"REG_GPOS_SEEN ");             \
810                                                                             \
811             if (RExC_seen & REG_CANY_SEEN)                                  \
812                 PerlIO_printf(Perl_debug_log,"REG_CANY_SEEN ");             \
813                                                                             \
814             if (RExC_seen & REG_RECURSE_SEEN)                               \
815                 PerlIO_printf(Perl_debug_log,"REG_RECURSE_SEEN ");          \
816                                                                             \
817             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                         \
818                 PerlIO_printf(Perl_debug_log,"REG_TOP_LEVEL_BRANCHES_SEEN ");    \
819                                                                             \
820             if (RExC_seen & REG_VERBARG_SEEN)                               \
821                 PerlIO_printf(Perl_debug_log,"REG_VERBARG_SEEN ");          \
822                                                                             \
823             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
824                 PerlIO_printf(Perl_debug_log,"REG_CUTGROUP_SEEN ");         \
825                                                                             \
826             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
827                 PerlIO_printf(Perl_debug_log,"REG_RUN_ON_COMMENT_SEEN ");   \
828                                                                             \
829             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
830                 PerlIO_printf(Perl_debug_log,"REG_UNFOLDED_MULTI_SEEN ");   \
831                                                                             \
832             if (RExC_seen & REG_GOSTART_SEEN)                               \
833                 PerlIO_printf(Perl_debug_log,"REG_GOSTART_SEEN ");          \
834                                                                             \
835             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                               \
836                 PerlIO_printf(Perl_debug_log,"REG_UNBOUNDED_QUANTIFIER_SEEN ");          \
837                                                                             \
838             PerlIO_printf(Perl_debug_log,"\n");                             \
839         });
840
841 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
842   if ((flags) & flag) PerlIO_printf(Perl_debug_log, "%s ", #flag)
843
844 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
845     if ( ( flags ) ) {                                                      \
846         PerlIO_printf(Perl_debug_log, "%s", open_str);                      \
847         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
848         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
849         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
850         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
851         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
852         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
853         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
854         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
855         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
856         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
857         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
858         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
859         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
860         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
861         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
862         PerlIO_printf(Perl_debug_log, "%s", close_str);                     \
863     }
864
865
866 #define DEBUG_STUDYDATA(str,data,depth)                              \
867 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
868     PerlIO_printf(Perl_debug_log,                                    \
869         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
870         " Flags: 0x%"UVXf,                                           \
871         (int)(depth)*2, "",                                          \
872         (IV)((data)->pos_min),                                       \
873         (IV)((data)->pos_delta),                                     \
874         (UV)((data)->flags)                                          \
875     );                                                               \
876     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
877     PerlIO_printf(Perl_debug_log,                                    \
878         " Whilem_c: %"IVdf" Lcp: %"IVdf" %s",                        \
879         (IV)((data)->whilem_c),                                      \
880         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
881         is_inf ? "INF " : ""                                         \
882     );                                                               \
883     if ((data)->last_found)                                          \
884         PerlIO_printf(Perl_debug_log,                                \
885             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
886             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
887             SvPVX_const((data)->last_found),                         \
888             (IV)((data)->last_end),                                  \
889             (IV)((data)->last_start_min),                            \
890             (IV)((data)->last_start_max),                            \
891             ((data)->longest &&                                      \
892              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
893             SvPVX_const((data)->longest_fixed),                      \
894             (IV)((data)->offset_fixed),                              \
895             ((data)->longest &&                                      \
896              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
897             SvPVX_const((data)->longest_float),                      \
898             (IV)((data)->offset_float_min),                          \
899             (IV)((data)->offset_float_max)                           \
900         );                                                           \
901     PerlIO_printf(Perl_debug_log,"\n");                              \
902 });
903
904 /* is c a control character for which we have a mnemonic? */
905 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
906
907 STATIC const char *
908 S_cntrl_to_mnemonic(const U8 c)
909 {
910     /* Returns the mnemonic string that represents character 'c', if one
911      * exists; NULL otherwise.  The only ones that exist for the purposes of
912      * this routine are a few control characters */
913
914     switch (c) {
915         case '\a':       return "\\a";
916         case '\b':       return "\\b";
917         case ESC_NATIVE: return "\\e";
918         case '\f':       return "\\f";
919         case '\n':       return "\\n";
920         case '\r':       return "\\r";
921         case '\t':       return "\\t";
922     }
923
924     return NULL;
925 }
926
927 /* Mark that we cannot extend a found fixed substring at this point.
928    Update the longest found anchored substring and the longest found
929    floating substrings if needed. */
930
931 STATIC void
932 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
933                     SSize_t *minlenp, int is_inf)
934 {
935     const STRLEN l = CHR_SVLEN(data->last_found);
936     const STRLEN old_l = CHR_SVLEN(*data->longest);
937     GET_RE_DEBUG_FLAGS_DECL;
938
939     PERL_ARGS_ASSERT_SCAN_COMMIT;
940
941     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
942         SvSetMagicSV(*data->longest, data->last_found);
943         if (*data->longest == data->longest_fixed) {
944             data->offset_fixed = l ? data->last_start_min : data->pos_min;
945             if (data->flags & SF_BEFORE_EOL)
946                 data->flags
947                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
948             else
949                 data->flags &= ~SF_FIX_BEFORE_EOL;
950             data->minlen_fixed=minlenp;
951             data->lookbehind_fixed=0;
952         }
953         else { /* *data->longest == data->longest_float */
954             data->offset_float_min = l ? data->last_start_min : data->pos_min;
955             data->offset_float_max = (l
956                           ? data->last_start_max
957                           : (data->pos_delta > SSize_t_MAX - data->pos_min
958                                          ? SSize_t_MAX
959                                          : data->pos_min + data->pos_delta));
960             if (is_inf
961                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
962                 data->offset_float_max = SSize_t_MAX;
963             if (data->flags & SF_BEFORE_EOL)
964                 data->flags
965                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
966             else
967                 data->flags &= ~SF_FL_BEFORE_EOL;
968             data->minlen_float=minlenp;
969             data->lookbehind_float=0;
970         }
971     }
972     SvCUR_set(data->last_found, 0);
973     {
974         SV * const sv = data->last_found;
975         if (SvUTF8(sv) && SvMAGICAL(sv)) {
976             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
977             if (mg)
978                 mg->mg_len = 0;
979         }
980     }
981     data->last_end = -1;
982     data->flags &= ~SF_BEFORE_EOL;
983     DEBUG_STUDYDATA("commit: ",data,0);
984 }
985
986 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
987  * list that describes which code points it matches */
988
989 STATIC void
990 S_ssc_anything(pTHX_ regnode_ssc *ssc)
991 {
992     /* Set the SSC 'ssc' to match an empty string or any code point */
993
994     PERL_ARGS_ASSERT_SSC_ANYTHING;
995
996     assert(is_ANYOF_SYNTHETIC(ssc));
997
998     ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */
999     _append_range_to_invlist(ssc->invlist, 0, UV_MAX);
1000     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1001 }
1002
1003 STATIC int
1004 S_ssc_is_anything(const regnode_ssc *ssc)
1005 {
1006     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1007      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1008      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1009      * in any way, so there's no point in using it */
1010
1011     UV start, end;
1012     bool ret;
1013
1014     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1015
1016     assert(is_ANYOF_SYNTHETIC(ssc));
1017
1018     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1019         return FALSE;
1020     }
1021
1022     /* See if the list consists solely of the range 0 - Infinity */
1023     invlist_iterinit(ssc->invlist);
1024     ret = invlist_iternext(ssc->invlist, &start, &end)
1025           && start == 0
1026           && end == UV_MAX;
1027
1028     invlist_iterfinish(ssc->invlist);
1029
1030     if (ret) {
1031         return TRUE;
1032     }
1033
1034     /* If e.g., both \w and \W are set, matches everything */
1035     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1036         int i;
1037         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1038             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1039                 return TRUE;
1040             }
1041         }
1042     }
1043
1044     return FALSE;
1045 }
1046
1047 STATIC void
1048 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1049 {
1050     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1051      * string, any code point, or any posix class under locale */
1052
1053     PERL_ARGS_ASSERT_SSC_INIT;
1054
1055     Zero(ssc, 1, regnode_ssc);
1056     set_ANYOF_SYNTHETIC(ssc);
1057     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1058     ssc_anything(ssc);
1059
1060     /* If any portion of the regex is to operate under locale rules that aren't
1061      * fully known at compile time, initialization includes it.  The reason
1062      * this isn't done for all regexes is that the optimizer was written under
1063      * the assumption that locale was all-or-nothing.  Given the complexity and
1064      * lack of documentation in the optimizer, and that there are inadequate
1065      * test cases for locale, many parts of it may not work properly, it is
1066      * safest to avoid locale unless necessary. */
1067     if (RExC_contains_locale) {
1068         ANYOF_POSIXL_SETALL(ssc);
1069     }
1070     else {
1071         ANYOF_POSIXL_ZERO(ssc);
1072     }
1073 }
1074
1075 STATIC int
1076 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1077                         const regnode_ssc *ssc)
1078 {
1079     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1080      * to the list of code points matched, and locale posix classes; hence does
1081      * not check its flags) */
1082
1083     UV start, end;
1084     bool ret;
1085
1086     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1087
1088     assert(is_ANYOF_SYNTHETIC(ssc));
1089
1090     invlist_iterinit(ssc->invlist);
1091     ret = invlist_iternext(ssc->invlist, &start, &end)
1092           && start == 0
1093           && end == UV_MAX;
1094
1095     invlist_iterfinish(ssc->invlist);
1096
1097     if (! ret) {
1098         return FALSE;
1099     }
1100
1101     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1102         return FALSE;
1103     }
1104
1105     return TRUE;
1106 }
1107
1108 STATIC SV*
1109 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1110                                const regnode_charclass* const node)
1111 {
1112     /* Returns a mortal inversion list defining which code points are matched
1113      * by 'node', which is of type ANYOF.  Handles complementing the result if
1114      * appropriate.  If some code points aren't knowable at this time, the
1115      * returned list must, and will, contain every code point that is a
1116      * possibility. */
1117
1118     SV* invlist = sv_2mortal(_new_invlist(0));
1119     SV* only_utf8_locale_invlist = NULL;
1120     unsigned int i;
1121     const U32 n = ARG(node);
1122     bool new_node_has_latin1 = FALSE;
1123
1124     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1125
1126     /* Look at the data structure created by S_set_ANYOF_arg() */
1127     if (n != ANYOF_ONLY_HAS_BITMAP) {
1128         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1129         AV * const av = MUTABLE_AV(SvRV(rv));
1130         SV **const ary = AvARRAY(av);
1131         assert(RExC_rxi->data->what[n] == 's');
1132
1133         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1134             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1135         }
1136         else if (ary[0] && ary[0] != &PL_sv_undef) {
1137
1138             /* Here, no compile-time swash, and there are things that won't be
1139              * known until runtime -- we have to assume it could be anything */
1140             return _add_range_to_invlist(invlist, 0, UV_MAX);
1141         }
1142         else if (ary[3] && ary[3] != &PL_sv_undef) {
1143
1144             /* Here no compile-time swash, and no run-time only data.  Use the
1145              * node's inversion list */
1146             invlist = sv_2mortal(invlist_clone(ary[3]));
1147         }
1148
1149         /* Get the code points valid only under UTF-8 locales */
1150         if ((ANYOF_FLAGS(node) & ANYOF_LOC_FOLD)
1151             && ary[2] && ary[2] != &PL_sv_undef)
1152         {
1153             only_utf8_locale_invlist = ary[2];
1154         }
1155     }
1156
1157     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1158      * code points, and an inversion list for the others, but if there are code
1159      * points that should match only conditionally on the target string being
1160      * UTF-8, those are placed in the inversion list, and not the bitmap.
1161      * Since there are circumstances under which they could match, they are
1162      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1163      * to exclude them here, so that when we invert below, the end result
1164      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1165      * have to do this here before we add the unconditionally matched code
1166      * points */
1167     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1168         _invlist_intersection_complement_2nd(invlist,
1169                                              PL_UpperLatin1,
1170                                              &invlist);
1171     }
1172
1173     /* Add in the points from the bit map */
1174     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1175         if (ANYOF_BITMAP_TEST(node, i)) {
1176             invlist = add_cp_to_invlist(invlist, i);
1177             new_node_has_latin1 = TRUE;
1178         }
1179     }
1180
1181     /* If this can match all upper Latin1 code points, have to add them
1182      * as well */
1183     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) {
1184         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1185     }
1186
1187     /* Similarly for these */
1188     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1189         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1190     }
1191
1192     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1193         _invlist_invert(invlist);
1194     }
1195     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOF_LOC_FOLD) {
1196
1197         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1198          * locale.  We can skip this if there are no 0-255 at all. */
1199         _invlist_union(invlist, PL_Latin1, &invlist);
1200     }
1201
1202     /* Similarly add the UTF-8 locale possible matches.  These have to be
1203      * deferred until after the non-UTF-8 locale ones are taken care of just
1204      * above, or it leads to wrong results under ANYOF_INVERT */
1205     if (only_utf8_locale_invlist) {
1206         _invlist_union_maybe_complement_2nd(invlist,
1207                                             only_utf8_locale_invlist,
1208                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1209                                             &invlist);
1210     }
1211
1212     return invlist;
1213 }
1214
1215 /* These two functions currently do the exact same thing */
1216 #define ssc_init_zero           ssc_init
1217
1218 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1219 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1220
1221 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1222  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1223  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1224
1225 STATIC void
1226 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1227                 const regnode_charclass *and_with)
1228 {
1229     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1230      * another SSC or a regular ANYOF class.  Can create false positives. */
1231
1232     SV* anded_cp_list;
1233     U8  anded_flags;
1234
1235     PERL_ARGS_ASSERT_SSC_AND;
1236
1237     assert(is_ANYOF_SYNTHETIC(ssc));
1238
1239     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1240      * the code point inversion list and just the relevant flags */
1241     if (is_ANYOF_SYNTHETIC(and_with)) {
1242         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1243         anded_flags = ANYOF_FLAGS(and_with);
1244
1245         /* XXX This is a kludge around what appears to be deficiencies in the
1246          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1247          * there are paths through the optimizer where it doesn't get weeded
1248          * out when it should.  And if we don't make some extra provision for
1249          * it like the code just below, it doesn't get added when it should.
1250          * This solution is to add it only when AND'ing, which is here, and
1251          * only when what is being AND'ed is the pristine, original node
1252          * matching anything.  Thus it is like adding it to ssc_anything() but
1253          * only when the result is to be AND'ed.  Probably the same solution
1254          * could be adopted for the same problem we have with /l matching,
1255          * which is solved differently in S_ssc_init(), and that would lead to
1256          * fewer false positives than that solution has.  But if this solution
1257          * creates bugs, the consequences are only that a warning isn't raised
1258          * that should be; while the consequences for having /l bugs is
1259          * incorrect matches */
1260         if (ssc_is_anything((regnode_ssc *)and_with)) {
1261             anded_flags |= ANYOF_WARN_SUPER;
1262         }
1263     }
1264     else {
1265         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1266         anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1267     }
1268
1269     ANYOF_FLAGS(ssc) &= anded_flags;
1270
1271     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1272      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1273      * 'and_with' may be inverted.  When not inverted, we have the situation of
1274      * computing:
1275      *  (C1 | P1) & (C2 | P2)
1276      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1277      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1278      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1279      *                    <=  ((C1 & C2) | P1 | P2)
1280      * Alternatively, the last few steps could be:
1281      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1282      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1283      *                    <=  (C1 | C2 | (P1 & P2))
1284      * We favor the second approach if either P1 or P2 is non-empty.  This is
1285      * because these components are a barrier to doing optimizations, as what
1286      * they match cannot be known until the moment of matching as they are
1287      * dependent on the current locale, 'AND"ing them likely will reduce or
1288      * eliminate them.
1289      * But we can do better if we know that C1,P1 are in their initial state (a
1290      * frequent occurrence), each matching everything:
1291      *  (<everything>) & (C2 | P2) =  C2 | P2
1292      * Similarly, if C2,P2 are in their initial state (again a frequent
1293      * occurrence), the result is a no-op
1294      *  (C1 | P1) & (<everything>) =  C1 | P1
1295      *
1296      * Inverted, we have
1297      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1298      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1299      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1300      * */
1301
1302     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1303         && ! is_ANYOF_SYNTHETIC(and_with))
1304     {
1305         unsigned int i;
1306
1307         ssc_intersection(ssc,
1308                          anded_cp_list,
1309                          FALSE /* Has already been inverted */
1310                          );
1311
1312         /* If either P1 or P2 is empty, the intersection will be also; can skip
1313          * the loop */
1314         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1315             ANYOF_POSIXL_ZERO(ssc);
1316         }
1317         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1318
1319             /* Note that the Posix class component P from 'and_with' actually
1320              * looks like:
1321              *      P = Pa | Pb | ... | Pn
1322              * where each component is one posix class, such as in [\w\s].
1323              * Thus
1324              *      ~P = ~(Pa | Pb | ... | Pn)
1325              *         = ~Pa & ~Pb & ... & ~Pn
1326              *        <= ~Pa | ~Pb | ... | ~Pn
1327              * The last is something we can easily calculate, but unfortunately
1328              * is likely to have many false positives.  We could do better
1329              * in some (but certainly not all) instances if two classes in
1330              * P have known relationships.  For example
1331              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1332              * So
1333              *      :lower: & :print: = :lower:
1334              * And similarly for classes that must be disjoint.  For example,
1335              * since \s and \w can have no elements in common based on rules in
1336              * the POSIX standard,
1337              *      \w & ^\S = nothing
1338              * Unfortunately, some vendor locales do not meet the Posix
1339              * standard, in particular almost everything by Microsoft.
1340              * The loop below just changes e.g., \w into \W and vice versa */
1341
1342             regnode_charclass_posixl temp;
1343             int add = 1;    /* To calculate the index of the complement */
1344
1345             ANYOF_POSIXL_ZERO(&temp);
1346             for (i = 0; i < ANYOF_MAX; i++) {
1347                 assert(i % 2 != 0
1348                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1349                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1350
1351                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1352                     ANYOF_POSIXL_SET(&temp, i + add);
1353                 }
1354                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1355             }
1356             ANYOF_POSIXL_AND(&temp, ssc);
1357
1358         } /* else ssc already has no posixes */
1359     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1360          in its initial state */
1361     else if (! is_ANYOF_SYNTHETIC(and_with)
1362              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1363     {
1364         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1365          * copy it over 'ssc' */
1366         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1367             if (is_ANYOF_SYNTHETIC(and_with)) {
1368                 StructCopy(and_with, ssc, regnode_ssc);
1369             }
1370             else {
1371                 ssc->invlist = anded_cp_list;
1372                 ANYOF_POSIXL_ZERO(ssc);
1373                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1374                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1375                 }
1376             }
1377         }
1378         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1379                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1380         {
1381             /* One or the other of P1, P2 is non-empty. */
1382             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1383                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1384             }
1385             ssc_union(ssc, anded_cp_list, FALSE);
1386         }
1387         else { /* P1 = P2 = empty */
1388             ssc_intersection(ssc, anded_cp_list, FALSE);
1389         }
1390     }
1391 }
1392
1393 STATIC void
1394 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1395                const regnode_charclass *or_with)
1396 {
1397     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1398      * another SSC or a regular ANYOF class.  Can create false positives if
1399      * 'or_with' is to be inverted. */
1400
1401     SV* ored_cp_list;
1402     U8 ored_flags;
1403
1404     PERL_ARGS_ASSERT_SSC_OR;
1405
1406     assert(is_ANYOF_SYNTHETIC(ssc));
1407
1408     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1409      * the code point inversion list and just the relevant flags */
1410     if (is_ANYOF_SYNTHETIC(or_with)) {
1411         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1412         ored_flags = ANYOF_FLAGS(or_with);
1413     }
1414     else {
1415         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1416         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1417     }
1418
1419     ANYOF_FLAGS(ssc) |= ored_flags;
1420
1421     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1422      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1423      * 'or_with' may be inverted.  When not inverted, we have the simple
1424      * situation of computing:
1425      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1426      * If P1|P2 yields a situation with both a class and its complement are
1427      * set, like having both \w and \W, this matches all code points, and we
1428      * can delete these from the P component of the ssc going forward.  XXX We
1429      * might be able to delete all the P components, but I (khw) am not certain
1430      * about this, and it is better to be safe.
1431      *
1432      * Inverted, we have
1433      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1434      *                         <=  (C1 | P1) | ~C2
1435      *                         <=  (C1 | ~C2) | P1
1436      * (which results in actually simpler code than the non-inverted case)
1437      * */
1438
1439     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1440         && ! is_ANYOF_SYNTHETIC(or_with))
1441     {
1442         /* We ignore P2, leaving P1 going forward */
1443     }   /* else  Not inverted */
1444     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1445         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1446         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1447             unsigned int i;
1448             for (i = 0; i < ANYOF_MAX; i += 2) {
1449                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1450                 {
1451                     ssc_match_all_cp(ssc);
1452                     ANYOF_POSIXL_CLEAR(ssc, i);
1453                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1454                 }
1455             }
1456         }
1457     }
1458
1459     ssc_union(ssc,
1460               ored_cp_list,
1461               FALSE /* Already has been inverted */
1462               );
1463 }
1464
1465 PERL_STATIC_INLINE void
1466 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1467 {
1468     PERL_ARGS_ASSERT_SSC_UNION;
1469
1470     assert(is_ANYOF_SYNTHETIC(ssc));
1471
1472     _invlist_union_maybe_complement_2nd(ssc->invlist,
1473                                         invlist,
1474                                         invert2nd,
1475                                         &ssc->invlist);
1476 }
1477
1478 PERL_STATIC_INLINE void
1479 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1480                          SV* const invlist,
1481                          const bool invert2nd)
1482 {
1483     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1484
1485     assert(is_ANYOF_SYNTHETIC(ssc));
1486
1487     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1488                                                invlist,
1489                                                invert2nd,
1490                                                &ssc->invlist);
1491 }
1492
1493 PERL_STATIC_INLINE void
1494 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1495 {
1496     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1497
1498     assert(is_ANYOF_SYNTHETIC(ssc));
1499
1500     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1501 }
1502
1503 PERL_STATIC_INLINE void
1504 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1505 {
1506     /* AND just the single code point 'cp' into the SSC 'ssc' */
1507
1508     SV* cp_list = _new_invlist(2);
1509
1510     PERL_ARGS_ASSERT_SSC_CP_AND;
1511
1512     assert(is_ANYOF_SYNTHETIC(ssc));
1513
1514     cp_list = add_cp_to_invlist(cp_list, cp);
1515     ssc_intersection(ssc, cp_list,
1516                      FALSE /* Not inverted */
1517                      );
1518     SvREFCNT_dec_NN(cp_list);
1519 }
1520
1521 PERL_STATIC_INLINE void
1522 S_ssc_clear_locale(regnode_ssc *ssc)
1523 {
1524     /* Set the SSC 'ssc' to not match any locale things */
1525     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1526
1527     assert(is_ANYOF_SYNTHETIC(ssc));
1528
1529     ANYOF_POSIXL_ZERO(ssc);
1530     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1531 }
1532
1533 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1534
1535 STATIC bool
1536 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1537 {
1538     /* The synthetic start class is used to hopefully quickly winnow down
1539      * places where a pattern could start a match in the target string.  If it
1540      * doesn't really narrow things down that much, there isn't much point to
1541      * having the overhead of using it.  This function uses some very crude
1542      * heuristics to decide if to use the ssc or not.
1543      *
1544      * It returns TRUE if 'ssc' rules out more than half what it considers to
1545      * be the "likely" possible matches, but of course it doesn't know what the
1546      * actual things being matched are going to be; these are only guesses
1547      *
1548      * For /l matches, it assumes that the only likely matches are going to be
1549      *      in the 0-255 range, uniformly distributed, so half of that is 127
1550      * For /a and /d matches, it assumes that the likely matches will be just
1551      *      the ASCII range, so half of that is 63
1552      * For /u and there isn't anything matching above the Latin1 range, it
1553      *      assumes that that is the only range likely to be matched, and uses
1554      *      half that as the cut-off: 127.  If anything matches above Latin1,
1555      *      it assumes that all of Unicode could match (uniformly), except for
1556      *      non-Unicode code points and things in the General Category "Other"
1557      *      (unassigned, private use, surrogates, controls and formats).  This
1558      *      is a much large number. */
1559
1560     const U32 max_match = (LOC)
1561                           ? 127
1562                           : (! UNI_SEMANTICS)
1563                             ? 63
1564                             : (invlist_highest(ssc->invlist) < 256)
1565                               ? 127
1566                               : ((NON_OTHER_COUNT + 1) / 2) - 1;
1567     U32 count = 0;      /* Running total of number of code points matched by
1568                            'ssc' */
1569     UV start, end;      /* Start and end points of current range in inversion
1570                            list */
1571
1572     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1573
1574     invlist_iterinit(ssc->invlist);
1575     while (invlist_iternext(ssc->invlist, &start, &end)) {
1576
1577         /* /u is the only thing that we expect to match above 255; so if not /u
1578          * and even if there are matches above 255, ignore them.  This catches
1579          * things like \d under /d which does match the digits above 255, but
1580          * since the pattern is /d, it is not likely to be expecting them */
1581         if (! UNI_SEMANTICS) {
1582             if (start > 255) {
1583                 break;
1584             }
1585             end = MIN(end, 255);
1586         }
1587         count += end - start + 1;
1588         if (count > max_match) {
1589             invlist_iterfinish(ssc->invlist);
1590             return FALSE;
1591         }
1592     }
1593
1594     return TRUE;
1595 }
1596
1597
1598 STATIC void
1599 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1600 {
1601     /* The inversion list in the SSC is marked mortal; now we need a more
1602      * permanent copy, which is stored the same way that is done in a regular
1603      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1604      * map */
1605
1606     SV* invlist = invlist_clone(ssc->invlist);
1607
1608     PERL_ARGS_ASSERT_SSC_FINALIZE;
1609
1610     assert(is_ANYOF_SYNTHETIC(ssc));
1611
1612     /* The code in this file assumes that all but these flags aren't relevant
1613      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1614      * by the time we reach here */
1615     assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS));
1616
1617     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1618
1619     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1620                                 NULL, NULL, NULL, FALSE);
1621
1622     /* Make sure is clone-safe */
1623     ssc->invlist = NULL;
1624
1625     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1626         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1627     }
1628
1629     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1630 }
1631
1632 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1633 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1634 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1635 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1636                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1637                                : 0 )
1638
1639
1640 #ifdef DEBUGGING
1641 /*
1642    dump_trie(trie,widecharmap,revcharmap)
1643    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1644    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1645
1646    These routines dump out a trie in a somewhat readable format.
1647    The _interim_ variants are used for debugging the interim
1648    tables that are used to generate the final compressed
1649    representation which is what dump_trie expects.
1650
1651    Part of the reason for their existence is to provide a form
1652    of documentation as to how the different representations function.
1653
1654 */
1655
1656 /*
1657   Dumps the final compressed table form of the trie to Perl_debug_log.
1658   Used for debugging make_trie().
1659 */
1660
1661 STATIC void
1662 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1663             AV *revcharmap, U32 depth)
1664 {
1665     U32 state;
1666     SV *sv=sv_newmortal();
1667     int colwidth= widecharmap ? 6 : 4;
1668     U16 word;
1669     GET_RE_DEBUG_FLAGS_DECL;
1670
1671     PERL_ARGS_ASSERT_DUMP_TRIE;
1672
1673     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1674         (int)depth * 2 + 2,"",
1675         "Match","Base","Ofs" );
1676
1677     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1678         SV ** const tmp = av_fetch( revcharmap, state, 0);
1679         if ( tmp ) {
1680             PerlIO_printf( Perl_debug_log, "%*s",
1681                 colwidth,
1682                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1683                             PL_colors[0], PL_colors[1],
1684                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1685                             PERL_PV_ESCAPE_FIRSTCHAR
1686                 )
1687             );
1688         }
1689     }
1690     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1691         (int)depth * 2 + 2,"");
1692
1693     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1694         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1695     PerlIO_printf( Perl_debug_log, "\n");
1696
1697     for( state = 1 ; state < trie->statecount ; state++ ) {
1698         const U32 base = trie->states[ state ].trans.base;
1699
1700         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|",
1701                                        (int)depth * 2 + 2,"", (UV)state);
1702
1703         if ( trie->states[ state ].wordnum ) {
1704             PerlIO_printf( Perl_debug_log, " W%4X",
1705                                            trie->states[ state ].wordnum );
1706         } else {
1707             PerlIO_printf( Perl_debug_log, "%6s", "" );
1708         }
1709
1710         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1711
1712         if ( base ) {
1713             U32 ofs = 0;
1714
1715             while( ( base + ofs  < trie->uniquecharcount ) ||
1716                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1717                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
1718                                                                     != state))
1719                     ofs++;
1720
1721             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1722
1723             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1724                 if ( ( base + ofs >= trie->uniquecharcount )
1725                         && ( base + ofs - trie->uniquecharcount
1726                                                         < trie->lasttrans )
1727                         && trie->trans[ base + ofs
1728                                     - trie->uniquecharcount ].check == state )
1729                 {
1730                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1731                     colwidth,
1732                     (UV)trie->trans[ base + ofs
1733                                              - trie->uniquecharcount ].next );
1734                 } else {
1735                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1736                 }
1737             }
1738
1739             PerlIO_printf( Perl_debug_log, "]");
1740
1741         }
1742         PerlIO_printf( Perl_debug_log, "\n" );
1743     }
1744     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=",
1745                                 (int)depth*2, "");
1746     for (word=1; word <= trie->wordcount; word++) {
1747         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1748             (int)word, (int)(trie->wordinfo[word].prev),
1749             (int)(trie->wordinfo[word].len));
1750     }
1751     PerlIO_printf(Perl_debug_log, "\n" );
1752 }
1753 /*
1754   Dumps a fully constructed but uncompressed trie in list form.
1755   List tries normally only are used for construction when the number of
1756   possible chars (trie->uniquecharcount) is very high.
1757   Used for debugging make_trie().
1758 */
1759 STATIC void
1760 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1761                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1762                          U32 depth)
1763 {
1764     U32 state;
1765     SV *sv=sv_newmortal();
1766     int colwidth= widecharmap ? 6 : 4;
1767     GET_RE_DEBUG_FLAGS_DECL;
1768
1769     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1770
1771     /* print out the table precompression.  */
1772     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1773         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1774         "------:-----+-----------------\n" );
1775
1776     for( state=1 ; state < next_alloc ; state ++ ) {
1777         U16 charid;
1778
1779         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1780             (int)depth * 2 + 2,"", (UV)state  );
1781         if ( ! trie->states[ state ].wordnum ) {
1782             PerlIO_printf( Perl_debug_log, "%5s| ","");
1783         } else {
1784             PerlIO_printf( Perl_debug_log, "W%4x| ",
1785                 trie->states[ state ].wordnum
1786             );
1787         }
1788         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1789             SV ** const tmp = av_fetch( revcharmap,
1790                                         TRIE_LIST_ITEM(state,charid).forid, 0);
1791             if ( tmp ) {
1792                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1793                     colwidth,
1794                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
1795                               colwidth,
1796                               PL_colors[0], PL_colors[1],
1797                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
1798                               | PERL_PV_ESCAPE_FIRSTCHAR
1799                     ) ,
1800                     TRIE_LIST_ITEM(state,charid).forid,
1801                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1802                 );
1803                 if (!(charid % 10))
1804                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1805                         (int)((depth * 2) + 14), "");
1806             }
1807         }
1808         PerlIO_printf( Perl_debug_log, "\n");
1809     }
1810 }
1811
1812 /*
1813   Dumps a fully constructed but uncompressed trie in table form.
1814   This is the normal DFA style state transition table, with a few
1815   twists to facilitate compression later.
1816   Used for debugging make_trie().
1817 */
1818 STATIC void
1819 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1820                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1821                           U32 depth)
1822 {
1823     U32 state;
1824     U16 charid;
1825     SV *sv=sv_newmortal();
1826     int colwidth= widecharmap ? 6 : 4;
1827     GET_RE_DEBUG_FLAGS_DECL;
1828
1829     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1830
1831     /*
1832        print out the table precompression so that we can do a visual check
1833        that they are identical.
1834      */
1835
1836     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1837
1838     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1839         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1840         if ( tmp ) {
1841             PerlIO_printf( Perl_debug_log, "%*s",
1842                 colwidth,
1843                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1844                             PL_colors[0], PL_colors[1],
1845                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1846                             PERL_PV_ESCAPE_FIRSTCHAR
1847                 )
1848             );
1849         }
1850     }
1851
1852     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1853
1854     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1855         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1856     }
1857
1858     PerlIO_printf( Perl_debug_log, "\n" );
1859
1860     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1861
1862         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1863             (int)depth * 2 + 2,"",
1864             (UV)TRIE_NODENUM( state ) );
1865
1866         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1867             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1868             if (v)
1869                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1870             else
1871                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1872         }
1873         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1874             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n",
1875                                             (UV)trie->trans[ state ].check );
1876         } else {
1877             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n",
1878                                             (UV)trie->trans[ state ].check,
1879             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1880         }
1881     }
1882 }
1883
1884 #endif
1885
1886
1887 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1888   startbranch: the first branch in the whole branch sequence
1889   first      : start branch of sequence of branch-exact nodes.
1890                May be the same as startbranch
1891   last       : Thing following the last branch.
1892                May be the same as tail.
1893   tail       : item following the branch sequence
1894   count      : words in the sequence
1895   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
1896   depth      : indent depth
1897
1898 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1899
1900 A trie is an N'ary tree where the branches are determined by digital
1901 decomposition of the key. IE, at the root node you look up the 1st character and
1902 follow that branch repeat until you find the end of the branches. Nodes can be
1903 marked as "accepting" meaning they represent a complete word. Eg:
1904
1905   /he|she|his|hers/
1906
1907 would convert into the following structure. Numbers represent states, letters
1908 following numbers represent valid transitions on the letter from that state, if
1909 the number is in square brackets it represents an accepting state, otherwise it
1910 will be in parenthesis.
1911
1912       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1913       |    |
1914       |   (2)
1915       |    |
1916      (1)   +-i->(6)-+-s->[7]
1917       |
1918       +-s->(3)-+-h->(4)-+-e->[5]
1919
1920       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1921
1922 This shows that when matching against the string 'hers' we will begin at state 1
1923 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1924 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1925 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1926 single traverse. We store a mapping from accepting to state to which word was
1927 matched, and then when we have multiple possibilities we try to complete the
1928 rest of the regex in the order in which they occurred in the alternation.
1929
1930 The only prior NFA like behaviour that would be changed by the TRIE support is
1931 the silent ignoring of duplicate alternations which are of the form:
1932
1933  / (DUPE|DUPE) X? (?{ ... }) Y /x
1934
1935 Thus EVAL blocks following a trie may be called a different number of times with
1936 and without the optimisation. With the optimisations dupes will be silently
1937 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1938 the following demonstrates:
1939
1940  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1941
1942 which prints out 'word' three times, but
1943
1944  'words'=~/(word|word|word)(?{ print $1 })S/
1945
1946 which doesnt print it out at all. This is due to other optimisations kicking in.
1947
1948 Example of what happens on a structural level:
1949
1950 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1951
1952    1: CURLYM[1] {1,32767}(18)
1953    5:   BRANCH(8)
1954    6:     EXACT <ac>(16)
1955    8:   BRANCH(11)
1956    9:     EXACT <ad>(16)
1957   11:   BRANCH(14)
1958   12:     EXACT <ab>(16)
1959   16:   SUCCEED(0)
1960   17:   NOTHING(18)
1961   18: END(0)
1962
1963 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1964 and should turn into:
1965
1966    1: CURLYM[1] {1,32767}(18)
1967    5:   TRIE(16)
1968         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1969           <ac>
1970           <ad>
1971           <ab>
1972   16:   SUCCEED(0)
1973   17:   NOTHING(18)
1974   18: END(0)
1975
1976 Cases where tail != last would be like /(?foo|bar)baz/:
1977
1978    1: BRANCH(4)
1979    2:   EXACT <foo>(8)
1980    4: BRANCH(7)
1981    5:   EXACT <bar>(8)
1982    7: TAIL(8)
1983    8: EXACT <baz>(10)
1984   10: END(0)
1985
1986 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1987 and would end up looking like:
1988
1989     1: TRIE(8)
1990       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1991         <foo>
1992         <bar>
1993    7: TAIL(8)
1994    8: EXACT <baz>(10)
1995   10: END(0)
1996
1997     d = uvchr_to_utf8_flags(d, uv, 0);
1998
1999 is the recommended Unicode-aware way of saying
2000
2001     *(d++) = uv;
2002 */
2003
2004 #define TRIE_STORE_REVCHAR(val)                                            \
2005     STMT_START {                                                           \
2006         if (UTF) {                                                         \
2007             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
2008             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2009             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2010             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2011             SvPOK_on(zlopp);                                               \
2012             SvUTF8_on(zlopp);                                              \
2013             av_push(revcharmap, zlopp);                                    \
2014         } else {                                                           \
2015             char ooooff = (char)val;                                           \
2016             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2017         }                                                                  \
2018         } STMT_END
2019
2020 /* This gets the next character from the input, folding it if not already
2021  * folded. */
2022 #define TRIE_READ_CHAR STMT_START {                                           \
2023     wordlen++;                                                                \
2024     if ( UTF ) {                                                              \
2025         /* if it is UTF then it is either already folded, or does not need    \
2026          * folding */                                                         \
2027         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2028     }                                                                         \
2029     else if (folder == PL_fold_latin1) {                                      \
2030         /* This folder implies Unicode rules, which in the range expressible  \
2031          *  by not UTF is the lower case, with the two exceptions, one of     \
2032          *  which should have been taken care of before calling this */       \
2033         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2034         uvc = toLOWER_L1(*uc);                                                \
2035         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2036         len = 1;                                                              \
2037     } else {                                                                  \
2038         /* raw data, will be folded later if needed */                        \
2039         uvc = (U32)*uc;                                                       \
2040         len = 1;                                                              \
2041     }                                                                         \
2042 } STMT_END
2043
2044
2045
2046 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2047     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2048         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
2049         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2050     }                                                           \
2051     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2052     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2053     TRIE_LIST_CUR( state )++;                                   \
2054 } STMT_END
2055
2056 #define TRIE_LIST_NEW(state) STMT_START {                       \
2057     Newxz( trie->states[ state ].trans.list,               \
2058         4, reg_trie_trans_le );                                 \
2059      TRIE_LIST_CUR( state ) = 1;                                \
2060      TRIE_LIST_LEN( state ) = 4;                                \
2061 } STMT_END
2062
2063 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2064     U16 dupe= trie->states[ state ].wordnum;                    \
2065     regnode * const noper_next = regnext( noper );              \
2066                                                                 \
2067     DEBUG_r({                                                   \
2068         /* store the word for dumping */                        \
2069         SV* tmp;                                                \
2070         if (OP(noper) != NOTHING)                               \
2071             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2072         else                                                    \
2073             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2074         av_push( trie_words, tmp );                             \
2075     });                                                         \
2076                                                                 \
2077     curword++;                                                  \
2078     trie->wordinfo[curword].prev   = 0;                         \
2079     trie->wordinfo[curword].len    = wordlen;                   \
2080     trie->wordinfo[curword].accept = state;                     \
2081                                                                 \
2082     if ( noper_next < tail ) {                                  \
2083         if (!trie->jump)                                        \
2084             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2085                                                  sizeof(U16) ); \
2086         trie->jump[curword] = (U16)(noper_next - convert);      \
2087         if (!jumper)                                            \
2088             jumper = noper_next;                                \
2089         if (!nextbranch)                                        \
2090             nextbranch= regnext(cur);                           \
2091     }                                                           \
2092                                                                 \
2093     if ( dupe ) {                                               \
2094         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2095         /* chain, so that when the bits of chain are later    */\
2096         /* linked together, the dups appear in the chain      */\
2097         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2098         trie->wordinfo[dupe].prev = curword;                    \
2099     } else {                                                    \
2100         /* we haven't inserted this word yet.                */ \
2101         trie->states[ state ].wordnum = curword;                \
2102     }                                                           \
2103 } STMT_END
2104
2105
2106 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2107      ( ( base + charid >=  ucharcount                                   \
2108          && base + charid < ubound                                      \
2109          && state == trie->trans[ base - ucharcount + charid ].check    \
2110          && trie->trans[ base - ucharcount + charid ].next )            \
2111            ? trie->trans[ base - ucharcount + charid ].next             \
2112            : ( state==1 ? special : 0 )                                 \
2113       )
2114
2115 #define MADE_TRIE       1
2116 #define MADE_JUMP_TRIE  2
2117 #define MADE_EXACT_TRIE 4
2118
2119 STATIC I32
2120 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2121                   regnode *first, regnode *last, regnode *tail,
2122                   U32 word_count, U32 flags, U32 depth)
2123 {
2124     /* first pass, loop through and scan words */
2125     reg_trie_data *trie;
2126     HV *widecharmap = NULL;
2127     AV *revcharmap = newAV();
2128     regnode *cur;
2129     STRLEN len = 0;
2130     UV uvc = 0;
2131     U16 curword = 0;
2132     U32 next_alloc = 0;
2133     regnode *jumper = NULL;
2134     regnode *nextbranch = NULL;
2135     regnode *convert = NULL;
2136     U32 *prev_states; /* temp array mapping each state to previous one */
2137     /* we just use folder as a flag in utf8 */
2138     const U8 * folder = NULL;
2139
2140 #ifdef DEBUGGING
2141     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2142     AV *trie_words = NULL;
2143     /* along with revcharmap, this only used during construction but both are
2144      * useful during debugging so we store them in the struct when debugging.
2145      */
2146 #else
2147     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2148     STRLEN trie_charcount=0;
2149 #endif
2150     SV *re_trie_maxbuff;
2151     GET_RE_DEBUG_FLAGS_DECL;
2152
2153     PERL_ARGS_ASSERT_MAKE_TRIE;
2154 #ifndef DEBUGGING
2155     PERL_UNUSED_ARG(depth);
2156 #endif
2157
2158     switch (flags) {
2159         case EXACT: case EXACTL: break;
2160         case EXACTFA:
2161         case EXACTFU_SS:
2162         case EXACTFU:
2163         case EXACTFLU8: folder = PL_fold_latin1; break;
2164         case EXACTF:  folder = PL_fold; break;
2165         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2166     }
2167
2168     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2169     trie->refcount = 1;
2170     trie->startstate = 1;
2171     trie->wordcount = word_count;
2172     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2173     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2174     if (flags == EXACT || flags == EXACTL)
2175         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2176     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2177                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2178
2179     DEBUG_r({
2180         trie_words = newAV();
2181     });
2182
2183     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2184     assert(re_trie_maxbuff);
2185     if (!SvIOK(re_trie_maxbuff)) {
2186         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2187     }
2188     DEBUG_TRIE_COMPILE_r({
2189         PerlIO_printf( Perl_debug_log,
2190           "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2191           (int)depth * 2 + 2, "",
2192           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2193           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2194     });
2195
2196    /* Find the node we are going to overwrite */
2197     if ( first == startbranch && OP( last ) != BRANCH ) {
2198         /* whole branch chain */
2199         convert = first;
2200     } else {
2201         /* branch sub-chain */
2202         convert = NEXTOPER( first );
2203     }
2204
2205     /*  -- First loop and Setup --
2206
2207        We first traverse the branches and scan each word to determine if it
2208        contains widechars, and how many unique chars there are, this is
2209        important as we have to build a table with at least as many columns as we
2210        have unique chars.
2211
2212        We use an array of integers to represent the character codes 0..255
2213        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2214        the native representation of the character value as the key and IV's for
2215        the coded index.
2216
2217        *TODO* If we keep track of how many times each character is used we can
2218        remap the columns so that the table compression later on is more
2219        efficient in terms of memory by ensuring the most common value is in the
2220        middle and the least common are on the outside.  IMO this would be better
2221        than a most to least common mapping as theres a decent chance the most
2222        common letter will share a node with the least common, meaning the node
2223        will not be compressible. With a middle is most common approach the worst
2224        case is when we have the least common nodes twice.
2225
2226      */
2227
2228     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2229         regnode *noper = NEXTOPER( cur );
2230         const U8 *uc = (U8*)STRING( noper );
2231         const U8 *e  = uc + STR_LEN( noper );
2232         int foldlen = 0;
2233         U32 wordlen      = 0;         /* required init */
2234         STRLEN minchars = 0;
2235         STRLEN maxchars = 0;
2236         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2237                                                bitmap?*/
2238
2239         if (OP(noper) == NOTHING) {
2240             regnode *noper_next= regnext(noper);
2241             if (noper_next != tail && OP(noper_next) == flags) {
2242                 noper = noper_next;
2243                 uc= (U8*)STRING(noper);
2244                 e= uc + STR_LEN(noper);
2245                 trie->minlen= STR_LEN(noper);
2246             } else {
2247                 trie->minlen= 0;
2248                 continue;
2249             }
2250         }
2251
2252         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2253             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2254                                           regardless of encoding */
2255             if (OP( noper ) == EXACTFU_SS) {
2256                 /* false positives are ok, so just set this */
2257                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2258             }
2259         }
2260         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2261                                            branch */
2262             TRIE_CHARCOUNT(trie)++;
2263             TRIE_READ_CHAR;
2264
2265             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2266              * is in effect.  Under /i, this character can match itself, or
2267              * anything that folds to it.  If not under /i, it can match just
2268              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2269              * all fold to k, and all are single characters.   But some folds
2270              * expand to more than one character, so for example LATIN SMALL
2271              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2272              * the string beginning at 'uc' is 'ffi', it could be matched by
2273              * three characters, or just by the one ligature character. (It
2274              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2275              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2276              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2277              * match.)  The trie needs to know the minimum and maximum number
2278              * of characters that could match so that it can use size alone to
2279              * quickly reject many match attempts.  The max is simple: it is
2280              * the number of folded characters in this branch (since a fold is
2281              * never shorter than what folds to it. */
2282
2283             maxchars++;
2284
2285             /* And the min is equal to the max if not under /i (indicated by
2286              * 'folder' being NULL), or there are no multi-character folds.  If
2287              * there is a multi-character fold, the min is incremented just
2288              * once, for the character that folds to the sequence.  Each
2289              * character in the sequence needs to be added to the list below of
2290              * characters in the trie, but we count only the first towards the
2291              * min number of characters needed.  This is done through the
2292              * variable 'foldlen', which is returned by the macros that look
2293              * for these sequences as the number of bytes the sequence
2294              * occupies.  Each time through the loop, we decrement 'foldlen' by
2295              * how many bytes the current char occupies.  Only when it reaches
2296              * 0 do we increment 'minchars' or look for another multi-character
2297              * sequence. */
2298             if (folder == NULL) {
2299                 minchars++;
2300             }
2301             else if (foldlen > 0) {
2302                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2303             }
2304             else {
2305                 minchars++;
2306
2307                 /* See if *uc is the beginning of a multi-character fold.  If
2308                  * so, we decrement the length remaining to look at, to account
2309                  * for the current character this iteration.  (We can use 'uc'
2310                  * instead of the fold returned by TRIE_READ_CHAR because for
2311                  * non-UTF, the latin1_safe macro is smart enough to account
2312                  * for all the unfolded characters, and because for UTF, the
2313                  * string will already have been folded earlier in the
2314                  * compilation process */
2315                 if (UTF) {
2316                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2317                         foldlen -= UTF8SKIP(uc);
2318                     }
2319                 }
2320                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2321                     foldlen--;
2322                 }
2323             }
2324
2325             /* The current character (and any potential folds) should be added
2326              * to the possible matching characters for this position in this
2327              * branch */
2328             if ( uvc < 256 ) {
2329                 if ( folder ) {
2330                     U8 folded= folder[ (U8) uvc ];
2331                     if ( !trie->charmap[ folded ] ) {
2332                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2333                         TRIE_STORE_REVCHAR( folded );
2334                     }
2335                 }
2336                 if ( !trie->charmap[ uvc ] ) {
2337                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2338                     TRIE_STORE_REVCHAR( uvc );
2339                 }
2340                 if ( set_bit ) {
2341                     /* store the codepoint in the bitmap, and its folded
2342                      * equivalent. */
2343                     TRIE_BITMAP_SET(trie, uvc);
2344
2345                     /* store the folded codepoint */
2346                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
2347
2348                     if ( !UTF ) {
2349                         /* store first byte of utf8 representation of
2350                            variant codepoints */
2351                         if (! UVCHR_IS_INVARIANT(uvc)) {
2352                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
2353                         }
2354                     }
2355                     set_bit = 0; /* We've done our bit :-) */
2356                 }
2357             } else {
2358
2359                 /* XXX We could come up with the list of code points that fold
2360                  * to this using PL_utf8_foldclosures, except not for
2361                  * multi-char folds, as there may be multiple combinations
2362                  * there that could work, which needs to wait until runtime to
2363                  * resolve (The comment about LIGATURE FFI above is such an
2364                  * example */
2365
2366                 SV** svpp;
2367                 if ( !widecharmap )
2368                     widecharmap = newHV();
2369
2370                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2371
2372                 if ( !svpp )
2373                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
2374
2375                 if ( !SvTRUE( *svpp ) ) {
2376                     sv_setiv( *svpp, ++trie->uniquecharcount );
2377                     TRIE_STORE_REVCHAR(uvc);
2378                 }
2379             }
2380         } /* end loop through characters in this branch of the trie */
2381
2382         /* We take the min and max for this branch and combine to find the min
2383          * and max for all branches processed so far */
2384         if( cur == first ) {
2385             trie->minlen = minchars;
2386             trie->maxlen = maxchars;
2387         } else if (minchars < trie->minlen) {
2388             trie->minlen = minchars;
2389         } else if (maxchars > trie->maxlen) {
2390             trie->maxlen = maxchars;
2391         }
2392     } /* end first pass */
2393     DEBUG_TRIE_COMPILE_r(
2394         PerlIO_printf( Perl_debug_log,
2395                 "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2396                 (int)depth * 2 + 2,"",
2397                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2398                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2399                 (int)trie->minlen, (int)trie->maxlen )
2400     );
2401
2402     /*
2403         We now know what we are dealing with in terms of unique chars and
2404         string sizes so we can calculate how much memory a naive
2405         representation using a flat table  will take. If it's over a reasonable
2406         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2407         conservative but potentially much slower representation using an array
2408         of lists.
2409
2410         At the end we convert both representations into the same compressed
2411         form that will be used in regexec.c for matching with. The latter
2412         is a form that cannot be used to construct with but has memory
2413         properties similar to the list form and access properties similar
2414         to the table form making it both suitable for fast searches and
2415         small enough that its feasable to store for the duration of a program.
2416
2417         See the comment in the code where the compressed table is produced
2418         inplace from the flat tabe representation for an explanation of how
2419         the compression works.
2420
2421     */
2422
2423
2424     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2425     prev_states[1] = 0;
2426
2427     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2428                                                     > SvIV(re_trie_maxbuff) )
2429     {
2430         /*
2431             Second Pass -- Array Of Lists Representation
2432
2433             Each state will be represented by a list of charid:state records
2434             (reg_trie_trans_le) the first such element holds the CUR and LEN
2435             points of the allocated array. (See defines above).
2436
2437             We build the initial structure using the lists, and then convert
2438             it into the compressed table form which allows faster lookups
2439             (but cant be modified once converted).
2440         */
2441
2442         STRLEN transcount = 1;
2443
2444         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2445             "%*sCompiling trie using list compiler\n",
2446             (int)depth * 2 + 2, ""));
2447
2448         trie->states = (reg_trie_state *)
2449             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2450                                   sizeof(reg_trie_state) );
2451         TRIE_LIST_NEW(1);
2452         next_alloc = 2;
2453
2454         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2455
2456             regnode *noper   = NEXTOPER( cur );
2457             U8 *uc           = (U8*)STRING( noper );
2458             const U8 *e      = uc + STR_LEN( noper );
2459             U32 state        = 1;         /* required init */
2460             U16 charid       = 0;         /* sanity init */
2461             U32 wordlen      = 0;         /* required init */
2462
2463             if (OP(noper) == NOTHING) {
2464                 regnode *noper_next= regnext(noper);
2465                 if (noper_next != tail && OP(noper_next) == flags) {
2466                     noper = noper_next;
2467                     uc= (U8*)STRING(noper);
2468                     e= uc + STR_LEN(noper);
2469                 }
2470             }
2471
2472             if (OP(noper) != NOTHING) {
2473                 for ( ; uc < e ; uc += len ) {
2474
2475                     TRIE_READ_CHAR;
2476
2477                     if ( uvc < 256 ) {
2478                         charid = trie->charmap[ uvc ];
2479                     } else {
2480                         SV** const svpp = hv_fetch( widecharmap,
2481                                                     (char*)&uvc,
2482                                                     sizeof( UV ),
2483                                                     0);
2484                         if ( !svpp ) {
2485                             charid = 0;
2486                         } else {
2487                             charid=(U16)SvIV( *svpp );
2488                         }
2489                     }
2490                     /* charid is now 0 if we dont know the char read, or
2491                      * nonzero if we do */
2492                     if ( charid ) {
2493
2494                         U16 check;
2495                         U32 newstate = 0;
2496
2497                         charid--;
2498                         if ( !trie->states[ state ].trans.list ) {
2499                             TRIE_LIST_NEW( state );
2500                         }
2501                         for ( check = 1;
2502                               check <= TRIE_LIST_USED( state );
2503                               check++ )
2504                         {
2505                             if ( TRIE_LIST_ITEM( state, check ).forid
2506                                                                     == charid )
2507                             {
2508                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2509                                 break;
2510                             }
2511                         }
2512                         if ( ! newstate ) {
2513                             newstate = next_alloc++;
2514                             prev_states[newstate] = state;
2515                             TRIE_LIST_PUSH( state, charid, newstate );
2516                             transcount++;
2517                         }
2518                         state = newstate;
2519                     } else {
2520                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2521                     }
2522                 }
2523             }
2524             TRIE_HANDLE_WORD(state);
2525
2526         } /* end second pass */
2527
2528         /* next alloc is the NEXT state to be allocated */
2529         trie->statecount = next_alloc;
2530         trie->states = (reg_trie_state *)
2531             PerlMemShared_realloc( trie->states,
2532                                    next_alloc
2533                                    * sizeof(reg_trie_state) );
2534
2535         /* and now dump it out before we compress it */
2536         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2537                                                          revcharmap, next_alloc,
2538                                                          depth+1)
2539         );
2540
2541         trie->trans = (reg_trie_trans *)
2542             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2543         {
2544             U32 state;
2545             U32 tp = 0;
2546             U32 zp = 0;
2547
2548
2549             for( state=1 ; state < next_alloc ; state ++ ) {
2550                 U32 base=0;
2551
2552                 /*
2553                 DEBUG_TRIE_COMPILE_MORE_r(
2554                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
2555                 );
2556                 */
2557
2558                 if (trie->states[state].trans.list) {
2559                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2560                     U16 maxid=minid;
2561                     U16 idx;
2562
2563                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2564                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2565                         if ( forid < minid ) {
2566                             minid=forid;
2567                         } else if ( forid > maxid ) {
2568                             maxid=forid;
2569                         }
2570                     }
2571                     if ( transcount < tp + maxid - minid + 1) {
2572                         transcount *= 2;
2573                         trie->trans = (reg_trie_trans *)
2574                             PerlMemShared_realloc( trie->trans,
2575                                                      transcount
2576                                                      * sizeof(reg_trie_trans) );
2577                         Zero( trie->trans + (transcount / 2),
2578                               transcount / 2,
2579                               reg_trie_trans );
2580                     }
2581                     base = trie->uniquecharcount + tp - minid;
2582                     if ( maxid == minid ) {
2583                         U32 set = 0;
2584                         for ( ; zp < tp ; zp++ ) {
2585                             if ( ! trie->trans[ zp ].next ) {
2586                                 base = trie->uniquecharcount + zp - minid;
2587                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2588                                                                    1).newstate;
2589                                 trie->trans[ zp ].check = state;
2590                                 set = 1;
2591                                 break;
2592                             }
2593                         }
2594                         if ( !set ) {
2595                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2596                                                                    1).newstate;
2597                             trie->trans[ tp ].check = state;
2598                             tp++;
2599                             zp = tp;
2600                         }
2601                     } else {
2602                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2603                             const U32 tid = base
2604                                            - trie->uniquecharcount
2605                                            + TRIE_LIST_ITEM( state, idx ).forid;
2606                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2607                                                                 idx ).newstate;
2608                             trie->trans[ tid ].check = state;
2609                         }
2610                         tp += ( maxid - minid + 1 );
2611                     }
2612                     Safefree(trie->states[ state ].trans.list);
2613                 }
2614                 /*
2615                 DEBUG_TRIE_COMPILE_MORE_r(
2616                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
2617                 );
2618                 */
2619                 trie->states[ state ].trans.base=base;
2620             }
2621             trie->lasttrans = tp + 1;
2622         }
2623     } else {
2624         /*
2625            Second Pass -- Flat Table Representation.
2626
2627            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2628            each.  We know that we will need Charcount+1 trans at most to store
2629            the data (one row per char at worst case) So we preallocate both
2630            structures assuming worst case.
2631
2632            We then construct the trie using only the .next slots of the entry
2633            structs.
2634
2635            We use the .check field of the first entry of the node temporarily
2636            to make compression both faster and easier by keeping track of how
2637            many non zero fields are in the node.
2638
2639            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2640            transition.
2641
2642            There are two terms at use here: state as a TRIE_NODEIDX() which is
2643            a number representing the first entry of the node, and state as a
2644            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2645            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2646            if there are 2 entrys per node. eg:
2647
2648              A B       A B
2649           1. 2 4    1. 3 7
2650           2. 0 3    3. 0 5
2651           3. 0 0    5. 0 0
2652           4. 0 0    7. 0 0
2653
2654            The table is internally in the right hand, idx form. However as we
2655            also have to deal with the states array which is indexed by nodenum
2656            we have to use TRIE_NODENUM() to convert.
2657
2658         */
2659         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2660             "%*sCompiling trie using table compiler\n",
2661             (int)depth * 2 + 2, ""));
2662
2663         trie->trans = (reg_trie_trans *)
2664             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2665                                   * trie->uniquecharcount + 1,
2666                                   sizeof(reg_trie_trans) );
2667         trie->states = (reg_trie_state *)
2668             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2669                                   sizeof(reg_trie_state) );
2670         next_alloc = trie->uniquecharcount + 1;
2671
2672
2673         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2674
2675             regnode *noper   = NEXTOPER( cur );
2676             const U8 *uc     = (U8*)STRING( noper );
2677             const U8 *e      = uc + STR_LEN( noper );
2678
2679             U32 state        = 1;         /* required init */
2680
2681             U16 charid       = 0;         /* sanity init */
2682             U32 accept_state = 0;         /* sanity init */
2683
2684             U32 wordlen      = 0;         /* required init */
2685
2686             if (OP(noper) == NOTHING) {
2687                 regnode *noper_next= regnext(noper);
2688                 if (noper_next != tail && OP(noper_next) == flags) {
2689                     noper = noper_next;
2690                     uc= (U8*)STRING(noper);
2691                     e= uc + STR_LEN(noper);
2692                 }
2693             }
2694
2695             if ( OP(noper) != NOTHING ) {
2696                 for ( ; uc < e ; uc += len ) {
2697
2698                     TRIE_READ_CHAR;
2699
2700                     if ( uvc < 256 ) {
2701                         charid = trie->charmap[ uvc ];
2702                     } else {
2703                         SV* const * const svpp = hv_fetch( widecharmap,
2704                                                            (char*)&uvc,
2705                                                            sizeof( UV ),
2706                                                            0);
2707                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2708                     }
2709                     if ( charid ) {
2710                         charid--;
2711                         if ( !trie->trans[ state + charid ].next ) {
2712                             trie->trans[ state + charid ].next = next_alloc;
2713                             trie->trans[ state ].check++;
2714                             prev_states[TRIE_NODENUM(next_alloc)]
2715                                     = TRIE_NODENUM(state);
2716                             next_alloc += trie->uniquecharcount;
2717                         }
2718                         state = trie->trans[ state + charid ].next;
2719                     } else {
2720                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2721                     }
2722                     /* charid is now 0 if we dont know the char read, or
2723                      * nonzero if we do */
2724                 }
2725             }
2726             accept_state = TRIE_NODENUM( state );
2727             TRIE_HANDLE_WORD(accept_state);
2728
2729         } /* end second pass */
2730
2731         /* and now dump it out before we compress it */
2732         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2733                                                           revcharmap,
2734                                                           next_alloc, depth+1));
2735
2736         {
2737         /*
2738            * Inplace compress the table.*
2739
2740            For sparse data sets the table constructed by the trie algorithm will
2741            be mostly 0/FAIL transitions or to put it another way mostly empty.
2742            (Note that leaf nodes will not contain any transitions.)
2743
2744            This algorithm compresses the tables by eliminating most such
2745            transitions, at the cost of a modest bit of extra work during lookup:
2746
2747            - Each states[] entry contains a .base field which indicates the
2748            index in the state[] array wheres its transition data is stored.
2749
2750            - If .base is 0 there are no valid transitions from that node.
2751
2752            - If .base is nonzero then charid is added to it to find an entry in
2753            the trans array.
2754
2755            -If trans[states[state].base+charid].check!=state then the
2756            transition is taken to be a 0/Fail transition. Thus if there are fail
2757            transitions at the front of the node then the .base offset will point
2758            somewhere inside the previous nodes data (or maybe even into a node
2759            even earlier), but the .check field determines if the transition is
2760            valid.
2761
2762            XXX - wrong maybe?
2763            The following process inplace converts the table to the compressed
2764            table: We first do not compress the root node 1,and mark all its
2765            .check pointers as 1 and set its .base pointer as 1 as well. This
2766            allows us to do a DFA construction from the compressed table later,
2767            and ensures that any .base pointers we calculate later are greater
2768            than 0.
2769
2770            - We set 'pos' to indicate the first entry of the second node.
2771
2772            - We then iterate over the columns of the node, finding the first and
2773            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2774            and set the .check pointers accordingly, and advance pos
2775            appropriately and repreat for the next node. Note that when we copy
2776            the next pointers we have to convert them from the original
2777            NODEIDX form to NODENUM form as the former is not valid post
2778            compression.
2779
2780            - If a node has no transitions used we mark its base as 0 and do not
2781            advance the pos pointer.
2782
2783            - If a node only has one transition we use a second pointer into the
2784            structure to fill in allocated fail transitions from other states.
2785            This pointer is independent of the main pointer and scans forward
2786            looking for null transitions that are allocated to a state. When it
2787            finds one it writes the single transition into the "hole".  If the
2788            pointer doesnt find one the single transition is appended as normal.
2789
2790            - Once compressed we can Renew/realloc the structures to release the
2791            excess space.
2792
2793            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2794            specifically Fig 3.47 and the associated pseudocode.
2795
2796            demq
2797         */
2798         const U32 laststate = TRIE_NODENUM( next_alloc );
2799         U32 state, charid;
2800         U32 pos = 0, zp=0;
2801         trie->statecount = laststate;
2802
2803         for ( state = 1 ; state < laststate ; state++ ) {
2804             U8 flag = 0;
2805             const U32 stateidx = TRIE_NODEIDX( state );
2806             const U32 o_used = trie->trans[ stateidx ].check;
2807             U32 used = trie->trans[ stateidx ].check;
2808             trie->trans[ stateidx ].check = 0;
2809
2810             for ( charid = 0;
2811                   used && charid < trie->uniquecharcount;
2812                   charid++ )
2813             {
2814                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2815                     if ( trie->trans[ stateidx + charid ].next ) {
2816                         if (o_used == 1) {
2817                             for ( ; zp < pos ; zp++ ) {
2818                                 if ( ! trie->trans[ zp ].next ) {
2819                                     break;
2820                                 }
2821                             }
2822                             trie->states[ state ].trans.base
2823                                                     = zp
2824                                                       + trie->uniquecharcount
2825                                                       - charid ;
2826                             trie->trans[ zp ].next
2827                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
2828                                                              + charid ].next );
2829                             trie->trans[ zp ].check = state;
2830                             if ( ++zp > pos ) pos = zp;
2831                             break;
2832                         }
2833                         used--;
2834                     }
2835                     if ( !flag ) {
2836                         flag = 1;
2837                         trie->states[ state ].trans.base
2838                                        = pos + trie->uniquecharcount - charid ;
2839                     }
2840                     trie->trans[ pos ].next
2841                         = SAFE_TRIE_NODENUM(
2842                                        trie->trans[ stateidx + charid ].next );
2843                     trie->trans[ pos ].check = state;
2844                     pos++;
2845                 }
2846             }
2847         }
2848         trie->lasttrans = pos + 1;
2849         trie->states = (reg_trie_state *)
2850             PerlMemShared_realloc( trie->states, laststate
2851                                    * sizeof(reg_trie_state) );
2852         DEBUG_TRIE_COMPILE_MORE_r(
2853             PerlIO_printf( Perl_debug_log,
2854                 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2855                 (int)depth * 2 + 2,"",
2856                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
2857                        + 1 ),
2858                 (IV)next_alloc,
2859                 (IV)pos,
2860                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2861             );
2862
2863         } /* end table compress */
2864     }
2865     DEBUG_TRIE_COMPILE_MORE_r(
2866             PerlIO_printf(Perl_debug_log,
2867                 "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2868                 (int)depth * 2 + 2, "",
2869                 (UV)trie->statecount,
2870                 (UV)trie->lasttrans)
2871     );
2872     /* resize the trans array to remove unused space */
2873     trie->trans = (reg_trie_trans *)
2874         PerlMemShared_realloc( trie->trans, trie->lasttrans
2875                                * sizeof(reg_trie_trans) );
2876
2877     {   /* Modify the program and insert the new TRIE node */
2878         U8 nodetype =(U8)(flags & 0xFF);
2879         char *str=NULL;
2880
2881 #ifdef DEBUGGING
2882         regnode *optimize = NULL;
2883 #ifdef RE_TRACK_PATTERN_OFFSETS
2884
2885         U32 mjd_offset = 0;
2886         U32 mjd_nodelen = 0;
2887 #endif /* RE_TRACK_PATTERN_OFFSETS */
2888 #endif /* DEBUGGING */
2889         /*
2890            This means we convert either the first branch or the first Exact,
2891            depending on whether the thing following (in 'last') is a branch
2892            or not and whther first is the startbranch (ie is it a sub part of
2893            the alternation or is it the whole thing.)
2894            Assuming its a sub part we convert the EXACT otherwise we convert
2895            the whole branch sequence, including the first.
2896          */
2897         /* Find the node we are going to overwrite */
2898         if ( first != startbranch || OP( last ) == BRANCH ) {
2899             /* branch sub-chain */
2900             NEXT_OFF( first ) = (U16)(last - first);
2901 #ifdef RE_TRACK_PATTERN_OFFSETS
2902             DEBUG_r({
2903                 mjd_offset= Node_Offset((convert));
2904                 mjd_nodelen= Node_Length((convert));
2905             });
2906 #endif
2907             /* whole branch chain */
2908         }
2909 #ifdef RE_TRACK_PATTERN_OFFSETS
2910         else {
2911             DEBUG_r({
2912                 const  regnode *nop = NEXTOPER( convert );
2913                 mjd_offset= Node_Offset((nop));
2914                 mjd_nodelen= Node_Length((nop));
2915             });
2916         }
2917         DEBUG_OPTIMISE_r(
2918             PerlIO_printf(Perl_debug_log,
2919                 "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2920                 (int)depth * 2 + 2, "",
2921                 (UV)mjd_offset, (UV)mjd_nodelen)
2922         );
2923 #endif
2924         /* But first we check to see if there is a common prefix we can
2925            split out as an EXACT and put in front of the TRIE node.  */
2926         trie->startstate= 1;
2927         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2928             U32 state;
2929             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2930                 U32 ofs = 0;
2931                 I32 idx = -1;
2932                 U32 count = 0;
2933                 const U32 base = trie->states[ state ].trans.base;
2934
2935                 if ( trie->states[state].wordnum )
2936                         count = 1;
2937
2938                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2939                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2940                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2941                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2942                     {
2943                         if ( ++count > 1 ) {
2944                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2945                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2946                             if ( state == 1 ) break;
2947                             if ( count == 2 ) {
2948                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2949                                 DEBUG_OPTIMISE_r(
2950                                     PerlIO_printf(Perl_debug_log,
2951                                         "%*sNew Start State=%"UVuf" Class: [",
2952                                         (int)depth * 2 + 2, "",
2953                                         (UV)state));
2954                                 if (idx >= 0) {
2955                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2956                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2957
2958                                     TRIE_BITMAP_SET(trie,*ch);
2959                                     if ( folder )
2960                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2961                                     DEBUG_OPTIMISE_r(
2962                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2963                                     );
2964                                 }
2965                             }
2966                             TRIE_BITMAP_SET(trie,*ch);
2967                             if ( folder )
2968                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2969                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2970                         }
2971                         idx = ofs;
2972                     }
2973                 }
2974                 if ( count == 1 ) {
2975                     SV **tmp = av_fetch( revcharmap, idx, 0);
2976                     STRLEN len;
2977                     char *ch = SvPV( *tmp, len );
2978                     DEBUG_OPTIMISE_r({
2979                         SV *sv=sv_newmortal();
2980                         PerlIO_printf( Perl_debug_log,
2981                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2982                             (int)depth * 2 + 2, "",
2983                             (UV)state, (UV)idx,
2984                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2985                                 PL_colors[0], PL_colors[1],
2986                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2987                                 PERL_PV_ESCAPE_FIRSTCHAR
2988                             )
2989                         );
2990                     });
2991                     if ( state==1 ) {
2992                         OP( convert ) = nodetype;
2993                         str=STRING(convert);
2994                         STR_LEN(convert)=0;
2995                     }
2996                     STR_LEN(convert) += len;
2997                     while (len--)
2998                         *str++ = *ch++;
2999                 } else {
3000 #ifdef DEBUGGING
3001                     if (state>1)
3002                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
3003 #endif
3004                     break;
3005                 }
3006             }
3007             trie->prefixlen = (state-1);
3008             if (str) {
3009                 regnode *n = convert+NODE_SZ_STR(convert);
3010                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3011                 trie->startstate = state;
3012                 trie->minlen -= (state - 1);
3013                 trie->maxlen -= (state - 1);
3014 #ifdef DEBUGGING
3015                /* At least the UNICOS C compiler choked on this
3016                 * being argument to DEBUG_r(), so let's just have
3017                 * it right here. */
3018                if (
3019 #ifdef PERL_EXT_RE_BUILD
3020                    1
3021 #else
3022                    DEBUG_r_TEST
3023 #endif
3024                    ) {
3025                    regnode *fix = convert;
3026                    U32 word = trie->wordcount;
3027                    mjd_nodelen++;
3028                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3029                    while( ++fix < n ) {
3030                        Set_Node_Offset_Length(fix, 0, 0);
3031                    }
3032                    while (word--) {
3033                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3034                        if (tmp) {
3035                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3036                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3037                            else
3038                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3039                        }
3040                    }
3041                }
3042 #endif
3043                 if (trie->maxlen) {
3044                     convert = n;
3045                 } else {
3046                     NEXT_OFF(convert) = (U16)(tail - convert);
3047                     DEBUG_r(optimize= n);
3048                 }
3049             }
3050         }
3051         if (!jumper)
3052             jumper = last;
3053         if ( trie->maxlen ) {
3054             NEXT_OFF( convert ) = (U16)(tail - convert);
3055             ARG_SET( convert, data_slot );
3056             /* Store the offset to the first unabsorbed branch in
3057                jump[0], which is otherwise unused by the jump logic.
3058                We use this when dumping a trie and during optimisation. */
3059             if (trie->jump)
3060                 trie->jump[0] = (U16)(nextbranch - convert);
3061
3062             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3063              *   and there is a bitmap
3064              *   and the first "jump target" node we found leaves enough room
3065              * then convert the TRIE node into a TRIEC node, with the bitmap
3066              * embedded inline in the opcode - this is hypothetically faster.
3067              */
3068             if ( !trie->states[trie->startstate].wordnum
3069                  && trie->bitmap
3070                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3071             {
3072                 OP( convert ) = TRIEC;
3073                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3074                 PerlMemShared_free(trie->bitmap);
3075                 trie->bitmap= NULL;
3076             } else
3077                 OP( convert ) = TRIE;
3078
3079             /* store the type in the flags */
3080             convert->flags = nodetype;
3081             DEBUG_r({
3082             optimize = convert
3083                       + NODE_STEP_REGNODE
3084                       + regarglen[ OP( convert ) ];
3085             });
3086             /* XXX We really should free up the resource in trie now,
3087                    as we won't use them - (which resources?) dmq */
3088         }
3089         /* needed for dumping*/
3090         DEBUG_r(if (optimize) {
3091             regnode *opt = convert;
3092
3093             while ( ++opt < optimize) {
3094                 Set_Node_Offset_Length(opt,0,0);
3095             }
3096             /*
3097                 Try to clean up some of the debris left after the
3098                 optimisation.
3099              */
3100             while( optimize < jumper ) {
3101                 mjd_nodelen += Node_Length((optimize));
3102                 OP( optimize ) = OPTIMIZED;
3103                 Set_Node_Offset_Length(optimize,0,0);
3104                 optimize++;
3105             }
3106             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3107         });
3108     } /* end node insert */
3109
3110     /*  Finish populating the prev field of the wordinfo array.  Walk back
3111      *  from each accept state until we find another accept state, and if
3112      *  so, point the first word's .prev field at the second word. If the
3113      *  second already has a .prev field set, stop now. This will be the
3114      *  case either if we've already processed that word's accept state,
3115      *  or that state had multiple words, and the overspill words were
3116      *  already linked up earlier.
3117      */
3118     {
3119         U16 word;
3120         U32 state;
3121         U16 prev;
3122
3123         for (word=1; word <= trie->wordcount; word++) {
3124             prev = 0;
3125             if (trie->wordinfo[word].prev)
3126                 continue;
3127             state = trie->wordinfo[word].accept;
3128             while (state) {
3129                 state = prev_states[state];
3130                 if (!state)
3131                     break;
3132                 prev = trie->states[state].wordnum;
3133                 if (prev)
3134                     break;
3135             }
3136             trie->wordinfo[word].prev = prev;
3137         }
3138         Safefree(prev_states);
3139     }
3140
3141
3142     /* and now dump out the compressed format */
3143     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3144
3145     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3146 #ifdef DEBUGGING
3147     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3148     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3149 #else
3150     SvREFCNT_dec_NN(revcharmap);
3151 #endif
3152     return trie->jump
3153            ? MADE_JUMP_TRIE
3154            : trie->startstate>1
3155              ? MADE_EXACT_TRIE
3156              : MADE_TRIE;
3157 }
3158
3159 STATIC regnode *
3160 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3161 {
3162 /* The Trie is constructed and compressed now so we can build a fail array if
3163  * it's needed
3164
3165    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3166    3.32 in the
3167    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3168    Ullman 1985/88
3169    ISBN 0-201-10088-6
3170
3171    We find the fail state for each state in the trie, this state is the longest
3172    proper suffix of the current state's 'word' that is also a proper prefix of
3173    another word in our trie. State 1 represents the word '' and is thus the
3174    default fail state. This allows the DFA not to have to restart after its
3175    tried and failed a word at a given point, it simply continues as though it
3176    had been matching the other word in the first place.
3177    Consider
3178       'abcdgu'=~/abcdefg|cdgu/
3179    When we get to 'd' we are still matching the first word, we would encounter
3180    'g' which would fail, which would bring us to the state representing 'd' in
3181    the second word where we would try 'g' and succeed, proceeding to match
3182    'cdgu'.
3183  */
3184  /* add a fail transition */
3185     const U32 trie_offset = ARG(source);
3186     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3187     U32 *q;
3188     const U32 ucharcount = trie->uniquecharcount;
3189     const U32 numstates = trie->statecount;
3190     const U32 ubound = trie->lasttrans + ucharcount;
3191     U32 q_read = 0;
3192     U32 q_write = 0;
3193     U32 charid;
3194     U32 base = trie->states[ 1 ].trans.base;
3195     U32 *fail;
3196     reg_ac_data *aho;
3197     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3198     regnode *stclass;
3199     GET_RE_DEBUG_FLAGS_DECL;
3200
3201     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3202     PERL_UNUSED_CONTEXT;
3203 #ifndef DEBUGGING
3204     PERL_UNUSED_ARG(depth);
3205 #endif
3206
3207     if ( OP(source) == TRIE ) {
3208         struct regnode_1 *op = (struct regnode_1 *)
3209             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3210         StructCopy(source,op,struct regnode_1);
3211         stclass = (regnode *)op;
3212     } else {
3213         struct regnode_charclass *op = (struct regnode_charclass *)
3214             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3215         StructCopy(source,op,struct regnode_charclass);
3216         stclass = (regnode *)op;
3217     }
3218     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3219
3220     ARG_SET( stclass, data_slot );
3221     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3222     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3223     aho->trie=trie_offset;
3224     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3225     Copy( trie->states, aho->states, numstates, reg_trie_state );
3226     Newxz( q, numstates, U32);
3227     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3228     aho->refcount = 1;
3229     fail = aho->fail;
3230     /* initialize fail[0..1] to be 1 so that we always have
3231        a valid final fail state */
3232     fail[ 0 ] = fail[ 1 ] = 1;
3233
3234     for ( charid = 0; charid < ucharcount ; charid++ ) {
3235         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3236         if ( newstate ) {
3237             q[ q_write ] = newstate;
3238             /* set to point at the root */
3239             fail[ q[ q_write++ ] ]=1;
3240         }
3241     }
3242     while ( q_read < q_write) {
3243         const U32 cur = q[ q_read++ % numstates ];
3244         base = trie->states[ cur ].trans.base;
3245
3246         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3247             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3248             if (ch_state) {
3249                 U32 fail_state = cur;
3250                 U32 fail_base;
3251                 do {
3252                     fail_state = fail[ fail_state ];
3253                     fail_base = aho->states[ fail_state ].trans.base;
3254                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3255
3256                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3257                 fail[ ch_state ] = fail_state;
3258                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3259                 {
3260                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3261                 }
3262                 q[ q_write++ % numstates] = ch_state;
3263             }
3264         }
3265     }
3266     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3267        when we fail in state 1, this allows us to use the
3268        charclass scan to find a valid start char. This is based on the principle
3269        that theres a good chance the string being searched contains lots of stuff
3270        that cant be a start char.
3271      */
3272     fail[ 0 ] = fail[ 1 ] = 0;
3273     DEBUG_TRIE_COMPILE_r({
3274         PerlIO_printf(Perl_debug_log,
3275                       "%*sStclass Failtable (%"UVuf" states): 0",
3276                       (int)(depth * 2), "", (UV)numstates
3277         );
3278         for( q_read=1; q_read<numstates; q_read++ ) {
3279             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
3280         }
3281         PerlIO_printf(Perl_debug_log, "\n");
3282     });
3283     Safefree(q);
3284     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3285     return stclass;
3286 }
3287
3288
3289 #define DEBUG_PEEP(str,scan,depth) \
3290     DEBUG_OPTIMISE_r({if (scan){ \
3291        regnode *Next = regnext(scan); \
3292        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state); \
3293        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)", \
3294            (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3295            Next ? (REG_NODE_NUM(Next)) : 0 ); \
3296        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3297        PerlIO_printf(Perl_debug_log, "\n"); \
3298    }});
3299
3300 /* The below joins as many adjacent EXACTish nodes as possible into a single
3301  * one.  The regop may be changed if the node(s) contain certain sequences that
3302  * require special handling.  The joining is only done if:
3303  * 1) there is room in the current conglomerated node to entirely contain the
3304  *    next one.
3305  * 2) they are the exact same node type
3306  *
3307  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3308  * these get optimized out
3309  *
3310  * If a node is to match under /i (folded), the number of characters it matches
3311  * can be different than its character length if it contains a multi-character
3312  * fold.  *min_subtract is set to the total delta number of characters of the
3313  * input nodes.
3314  *
3315  * And *unfolded_multi_char is set to indicate whether or not the node contains
3316  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3317  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3318  * SMALL LETTER SHARP S, as only if the target string being matched against
3319  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3320  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3321  * whose components are all above the Latin1 range are not run-time locale
3322  * dependent, and have already been folded by the time this function is
3323  * called.)
3324  *
3325  * This is as good a place as any to discuss the design of handling these
3326  * multi-character fold sequences.  It's been wrong in Perl for a very long
3327  * time.  There are three code points in Unicode whose multi-character folds
3328  * were long ago discovered to mess things up.  The previous designs for
3329  * dealing with these involved assigning a special node for them.  This
3330  * approach doesn't always work, as evidenced by this example:
3331  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3332  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3333  * would match just the \xDF, it won't be able to handle the case where a
3334  * successful match would have to cross the node's boundary.  The new approach
3335  * that hopefully generally solves the problem generates an EXACTFU_SS node
3336  * that is "sss" in this case.
3337  *
3338  * It turns out that there are problems with all multi-character folds, and not
3339  * just these three.  Now the code is general, for all such cases.  The
3340  * approach taken is:
3341  * 1)   This routine examines each EXACTFish node that could contain multi-
3342  *      character folded sequences.  Since a single character can fold into
3343  *      such a sequence, the minimum match length for this node is less than
3344  *      the number of characters in the node.  This routine returns in
3345  *      *min_subtract how many characters to subtract from the the actual
3346  *      length of the string to get a real minimum match length; it is 0 if
3347  *      there are no multi-char foldeds.  This delta is used by the caller to
3348  *      adjust the min length of the match, and the delta between min and max,
3349  *      so that the optimizer doesn't reject these possibilities based on size
3350  *      constraints.
3351  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3352  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3353  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3354  *      there is a possible fold length change.  That means that a regular
3355  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3356  *      with length changes, and so can be processed faster.  regexec.c takes
3357  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3358  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3359  *      known until runtime).  This saves effort in regex matching.  However,
3360  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3361  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3362  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3363  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3364  *      possibilities for the non-UTF8 patterns are quite simple, except for
3365  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3366  *      members of a fold-pair, and arrays are set up for all of them so that
3367  *      the other member of the pair can be found quickly.  Code elsewhere in
3368  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3369  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3370  *      described in the next item.
3371  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3372  *      validity of the fold won't be known until runtime, and so must remain
3373  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3374  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3375  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3376  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3377  *      The reason this is a problem is that the optimizer part of regexec.c
3378  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3379  *      that a character in the pattern corresponds to at most a single
3380  *      character in the target string.  (And I do mean character, and not byte
3381  *      here, unlike other parts of the documentation that have never been
3382  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3383  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3384  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3385  *      nodes, violate the assumption, and they are the only instances where it
3386  *      is violated.  I'm reluctant to try to change the assumption, as the
3387  *      code involved is impenetrable to me (khw), so instead the code here
3388  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3389  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3390  *      boolean indicating whether or not the node contains such a fold.  When
3391  *      it is true, the caller sets a flag that later causes the optimizer in
3392  *      this file to not set values for the floating and fixed string lengths,
3393  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3394  *      assumption.  Thus, there is no optimization based on string lengths for
3395  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3396  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3397  *      assumption is wrong only in these cases is that all other non-UTF-8
3398  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3399  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3400  *      EXACTF nodes because we don't know at compile time if it actually
3401  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3402  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3403  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3404  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3405  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3406  *      string would require the pattern to be forced into UTF-8, the overhead
3407  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3408  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3409  *      locale.)
3410  *
3411  *      Similarly, the code that generates tries doesn't currently handle
3412  *      not-already-folded multi-char folds, and it looks like a pain to change
3413  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3414  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3415  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3416  *      using /iaa matching will be doing so almost entirely with ASCII
3417  *      strings, so this should rarely be encountered in practice */
3418
3419 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3420     if (PL_regkind[OP(scan)] == EXACT) \
3421         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3422
3423 STATIC U32
3424 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3425                    UV *min_subtract, bool *unfolded_multi_char,
3426                    U32 flags,regnode *val, U32 depth)
3427 {
3428     /* Merge several consecutive EXACTish nodes into one. */
3429     regnode *n = regnext(scan);
3430     U32 stringok = 1;
3431     regnode *next = scan + NODE_SZ_STR(scan);
3432     U32 merged = 0;
3433     U32 stopnow = 0;
3434 #ifdef DEBUGGING
3435     regnode *stop = scan;
3436     GET_RE_DEBUG_FLAGS_DECL;
3437 #else
3438     PERL_UNUSED_ARG(depth);
3439 #endif
3440
3441     PERL_ARGS_ASSERT_JOIN_EXACT;
3442 #ifndef EXPERIMENTAL_INPLACESCAN
3443     PERL_UNUSED_ARG(flags);
3444     PERL_UNUSED_ARG(val);
3445 #endif
3446     DEBUG_PEEP("join",scan,depth);
3447
3448     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3449      * EXACT ones that are mergeable to the current one. */
3450     while (n
3451            && (PL_regkind[OP(n)] == NOTHING
3452                || (stringok && OP(n) == OP(scan)))
3453            && NEXT_OFF(n)
3454            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3455     {
3456
3457         if (OP(n) == TAIL || n > next)
3458             stringok = 0;
3459         if (PL_regkind[OP(n)] == NOTHING) {
3460             DEBUG_PEEP("skip:",n,depth);
3461             NEXT_OFF(scan) += NEXT_OFF(n);
3462             next = n + NODE_STEP_REGNODE;
3463 #ifdef DEBUGGING
3464             if (stringok)
3465                 stop = n;
3466 #endif
3467             n = regnext(n);
3468         }
3469         else if (stringok) {
3470             const unsigned int oldl = STR_LEN(scan);
3471             regnode * const nnext = regnext(n);
3472
3473             /* XXX I (khw) kind of doubt that this works on platforms (should
3474              * Perl ever run on one) where U8_MAX is above 255 because of lots
3475              * of other assumptions */
3476             /* Don't join if the sum can't fit into a single node */
3477             if (oldl + STR_LEN(n) > U8_MAX)
3478                 break;
3479
3480             DEBUG_PEEP("merg",n,depth);
3481             merged++;
3482
3483             NEXT_OFF(scan) += NEXT_OFF(n);
3484             STR_LEN(scan) += STR_LEN(n);
3485             next = n + NODE_SZ_STR(n);
3486             /* Now we can overwrite *n : */
3487             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3488 #ifdef DEBUGGING
3489             stop = next - 1;
3490 #endif
3491             n = nnext;
3492             if (stopnow) break;
3493         }
3494
3495 #ifdef EXPERIMENTAL_INPLACESCAN
3496         if (flags && !NEXT_OFF(n)) {
3497             DEBUG_PEEP("atch", val, depth);
3498             if (reg_off_by_arg[OP(n)]) {
3499                 ARG_SET(n, val - n);
3500             }
3501             else {
3502                 NEXT_OFF(n) = val - n;
3503             }
3504             stopnow = 1;
3505         }
3506 #endif
3507     }
3508
3509     *min_subtract = 0;
3510     *unfolded_multi_char = FALSE;
3511
3512     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3513      * can now analyze for sequences of problematic code points.  (Prior to
3514      * this final joining, sequences could have been split over boundaries, and
3515      * hence missed).  The sequences only happen in folding, hence for any
3516      * non-EXACT EXACTish node */
3517     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3518         U8* s0 = (U8*) STRING(scan);
3519         U8* s = s0;
3520         U8* s_end = s0 + STR_LEN(scan);
3521
3522         int total_count_delta = 0;  /* Total delta number of characters that
3523                                        multi-char folds expand to */
3524
3525         /* One pass is made over the node's string looking for all the
3526          * possibilities.  To avoid some tests in the loop, there are two main
3527          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3528          * non-UTF-8 */
3529         if (UTF) {
3530             U8* folded = NULL;
3531
3532             if (OP(scan) == EXACTFL) {
3533                 U8 *d;
3534
3535                 /* An EXACTFL node would already have been changed to another
3536                  * node type unless there is at least one character in it that
3537                  * is problematic; likely a character whose fold definition
3538                  * won't be known until runtime, and so has yet to be folded.
3539                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3540                  * to handle the UTF-8 case, we need to create a temporary
3541                  * folded copy using UTF-8 locale rules in order to analyze it.
3542                  * This is because our macros that look to see if a sequence is
3543                  * a multi-char fold assume everything is folded (otherwise the
3544                  * tests in those macros would be too complicated and slow).
3545                  * Note that here, the non-problematic folds will have already
3546                  * been done, so we can just copy such characters.  We actually
3547                  * don't completely fold the EXACTFL string.  We skip the
3548                  * unfolded multi-char folds, as that would just create work
3549                  * below to figure out the size they already are */
3550
3551                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3552                 d = folded;
3553                 while (s < s_end) {
3554                     STRLEN s_len = UTF8SKIP(s);
3555                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3556                         Copy(s, d, s_len, U8);
3557                         d += s_len;
3558                     }
3559                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3560                         *unfolded_multi_char = TRUE;
3561                         Copy(s, d, s_len, U8);
3562                         d += s_len;
3563                     }
3564                     else if (isASCII(*s)) {
3565                         *(d++) = toFOLD(*s);
3566                     }
3567                     else {
3568                         STRLEN len;
3569                         _to_utf8_fold_flags(s, d, &len, FOLD_FLAGS_FULL);
3570                         d += len;
3571                     }
3572                     s += s_len;
3573                 }
3574
3575                 /* Point the remainder of the routine to look at our temporary
3576                  * folded copy */
3577                 s = folded;
3578                 s_end = d;
3579             } /* End of creating folded copy of EXACTFL string */
3580
3581             /* Examine the string for a multi-character fold sequence.  UTF-8
3582              * patterns have all characters pre-folded by the time this code is
3583              * executed */
3584             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3585                                      length sequence we are looking for is 2 */
3586             {
3587                 int count = 0;  /* How many characters in a multi-char fold */
3588                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3589                 if (! len) {    /* Not a multi-char fold: get next char */
3590                     s += UTF8SKIP(s);
3591                     continue;
3592                 }
3593
3594                 /* Nodes with 'ss' require special handling, except for
3595                  * EXACTFA-ish for which there is no multi-char fold to this */
3596                 if (len == 2 && *s == 's' && *(s+1) == 's'
3597                     && OP(scan) != EXACTFA
3598                     && OP(scan) != EXACTFA_NO_TRIE)
3599                 {
3600                     count = 2;
3601                     if (OP(scan) != EXACTFL) {
3602                         OP(scan) = EXACTFU_SS;
3603                     }
3604                     s += 2;
3605                 }
3606                 else { /* Here is a generic multi-char fold. */
3607                     U8* multi_end  = s + len;
3608
3609                     /* Count how many characters are in it.  In the case of
3610                      * /aa, no folds which contain ASCII code points are
3611                      * allowed, so check for those, and skip if found. */
3612                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3613                         count = utf8_length(s, multi_end);
3614                         s = multi_end;
3615                     }
3616                     else {
3617                         while (s < multi_end) {
3618                             if (isASCII(*s)) {
3619                                 s++;
3620                                 goto next_iteration;
3621                             }
3622                             else {
3623                                 s += UTF8SKIP(s);
3624                             }
3625                             count++;
3626                         }
3627                     }
3628                 }
3629
3630                 /* The delta is how long the sequence is minus 1 (1 is how long
3631                  * the character that folds to the sequence is) */
3632                 total_count_delta += count - 1;
3633               next_iteration: ;
3634             }
3635
3636             /* We created a temporary folded copy of the string in EXACTFL
3637              * nodes.  Therefore we need to be sure it doesn't go below zero,
3638              * as the real string could be shorter */
3639             if (OP(scan) == EXACTFL) {
3640                 int total_chars = utf8_length((U8*) STRING(scan),
3641                                            (U8*) STRING(scan) + STR_LEN(scan));
3642                 if (total_count_delta > total_chars) {
3643                     total_count_delta = total_chars;
3644                 }
3645             }
3646
3647             *min_subtract += total_count_delta;
3648             Safefree(folded);
3649         }
3650         else if (OP(scan) == EXACTFA) {
3651
3652             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3653              * fold to the ASCII range (and there are no existing ones in the
3654              * upper latin1 range).  But, as outlined in the comments preceding
3655              * this function, we need to flag any occurrences of the sharp s.
3656              * This character forbids trie formation (because of added
3657              * complexity) */
3658             while (s < s_end) {
3659                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3660                     OP(scan) = EXACTFA_NO_TRIE;
3661                     *unfolded_multi_char = TRUE;
3662                     break;
3663                 }
3664                 s++;
3665                 continue;
3666             }
3667         }
3668         else {
3669
3670             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
3671              * folds that are all Latin1.  As explained in the comments
3672              * preceding this function, we look also for the sharp s in EXACTF
3673              * and EXACTFL nodes; it can be in the final position.  Otherwise
3674              * we can stop looking 1 byte earlier because have to find at least
3675              * two characters for a multi-fold */
3676             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
3677                               ? s_end
3678                               : s_end -1;
3679
3680             while (s < upper) {
3681                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
3682                 if (! len) {    /* Not a multi-char fold. */
3683                     if (*s == LATIN_SMALL_LETTER_SHARP_S
3684                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
3685                     {
3686                         *unfolded_multi_char = TRUE;
3687                     }
3688                     s++;
3689                     continue;
3690                 }
3691
3692                 if (len == 2
3693                     && isALPHA_FOLD_EQ(*s, 's')
3694                     && isALPHA_FOLD_EQ(*(s+1), 's'))
3695                 {
3696
3697                     /* EXACTF nodes need to know that the minimum length
3698                      * changed so that a sharp s in the string can match this
3699                      * ss in the pattern, but they remain EXACTF nodes, as they
3700                      * won't match this unless the target string is is UTF-8,
3701                      * which we don't know until runtime.  EXACTFL nodes can't
3702                      * transform into EXACTFU nodes */
3703                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
3704                         OP(scan) = EXACTFU_SS;
3705                     }
3706                 }
3707
3708                 *min_subtract += len - 1;
3709                 s += len;
3710             }
3711         }
3712     }
3713
3714 #ifdef DEBUGGING
3715     /* Allow dumping but overwriting the collection of skipped
3716      * ops and/or strings with fake optimized ops */
3717     n = scan + NODE_SZ_STR(scan);
3718     while (n <= stop) {
3719         OP(n) = OPTIMIZED;
3720         FLAGS(n) = 0;
3721         NEXT_OFF(n) = 0;
3722         n++;
3723     }
3724 #endif
3725     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
3726     return stopnow;
3727 }
3728
3729 /* REx optimizer.  Converts nodes into quicker variants "in place".
3730    Finds fixed substrings.  */
3731
3732 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
3733    to the position after last scanned or to NULL. */
3734
3735 #define INIT_AND_WITHP \
3736     assert(!and_withp); \
3737     Newx(and_withp,1, regnode_ssc); \
3738     SAVEFREEPV(and_withp)
3739
3740
3741 static void
3742 S_unwind_scan_frames(pTHX_ const void *p)
3743 {
3744     scan_frame *f= (scan_frame *)p;
3745     do {
3746         scan_frame *n= f->next_frame;
3747         Safefree(f);
3748         f= n;
3749     } while (f);
3750 }
3751
3752
3753 STATIC SSize_t
3754 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
3755                         SSize_t *minlenp, SSize_t *deltap,
3756                         regnode *last,
3757                         scan_data_t *data,
3758                         I32 stopparen,
3759                         U32 recursed_depth,
3760                         regnode_ssc *and_withp,
3761                         U32 flags, U32 depth)
3762                         /* scanp: Start here (read-write). */
3763                         /* deltap: Write maxlen-minlen here. */
3764                         /* last: Stop before this one. */
3765                         /* data: string data about the pattern */
3766                         /* stopparen: treat close N as END */
3767                         /* recursed: which subroutines have we recursed into */
3768                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3769 {
3770     /* There must be at least this number of characters to match */
3771     SSize_t min = 0;
3772     I32 pars = 0, code;
3773     regnode *scan = *scanp, *next;
3774     SSize_t delta = 0;
3775     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3776     int is_inf_internal = 0;            /* The studied chunk is infinite */
3777     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3778     scan_data_t data_fake;
3779     SV *re_trie_maxbuff = NULL;
3780     regnode *first_non_open = scan;
3781     SSize_t stopmin = SSize_t_MAX;
3782     scan_frame *frame = NULL;
3783     GET_RE_DEBUG_FLAGS_DECL;
3784
3785     PERL_ARGS_ASSERT_STUDY_CHUNK;
3786
3787
3788     if ( depth == 0 ) {
3789         while (first_non_open && OP(first_non_open) == OPEN)
3790             first_non_open=regnext(first_non_open);
3791     }
3792
3793
3794   fake_study_recurse:
3795     DEBUG_r(
3796         RExC_study_chunk_recursed_count++;
3797     );
3798     DEBUG_OPTIMISE_MORE_r(
3799     {
3800         PerlIO_printf(Perl_debug_log,
3801             "%*sstudy_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
3802             (int)(depth*2), "", (long)stopparen,
3803             (unsigned long)RExC_study_chunk_recursed_count,
3804             (unsigned long)depth, (unsigned long)recursed_depth,
3805             scan,
3806             last);
3807         if (recursed_depth) {
3808             U32 i;
3809             U32 j;
3810             for ( j = 0 ; j < recursed_depth ; j++ ) {
3811                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
3812                     if (
3813                         PAREN_TEST(RExC_study_chunk_recursed +
3814                                    ( j * RExC_study_chunk_recursed_bytes), i )
3815                         && (
3816                             !j ||
3817                             !PAREN_TEST(RExC_study_chunk_recursed +
3818                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
3819                         )
3820                     ) {
3821                         PerlIO_printf(Perl_debug_log," %d",(int)i);
3822                         break;
3823                     }
3824                 }
3825                 if ( j + 1 < recursed_depth ) {
3826                     PerlIO_printf(Perl_debug_log, ",");
3827                 }
3828             }
3829         }
3830         PerlIO_printf(Perl_debug_log,"\n");
3831     }
3832     );
3833     while ( scan && OP(scan) != END && scan < last ){
3834         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3835                                    node length to get a real minimum (because
3836                                    the folded version may be shorter) */
3837         bool unfolded_multi_char = FALSE;
3838         /* Peephole optimizer: */
3839         DEBUG_STUDYDATA("Peep:", data, depth);
3840         DEBUG_PEEP("Peep", scan, depth);
3841
3842
3843         /* The reason we do this here we need to deal with things like /(?:f)(?:o)(?:o)/
3844          * which cant be dealt with by the normal EXACT parsing code, as each (?:..) is handled
3845          * by a different invocation of reg() -- Yves
3846          */
3847         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
3848
3849         /* Follow the next-chain of the current node and optimize
3850            away all the NOTHINGs from it.  */
3851         if (OP(scan) != CURLYX) {
3852             const int max = (reg_off_by_arg[OP(scan)]
3853                        ? I32_MAX
3854                        /* I32 may be smaller than U16 on CRAYs! */
3855                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3856             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3857             int noff;
3858             regnode *n = scan;
3859
3860             /* Skip NOTHING and LONGJMP. */
3861             while ((n = regnext(n))
3862                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3863                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3864                    && off + noff < max)
3865                 off += noff;
3866             if (reg_off_by_arg[OP(scan)])
3867                 ARG(scan) = off;
3868             else
3869                 NEXT_OFF(scan) = off;
3870         }
3871
3872         /* The principal pseudo-switch.  Cannot be a switch, since we
3873            look into several different things.  */
3874         if ( OP(scan) == DEFINEP ) {
3875             SSize_t minlen = 0;
3876             SSize_t deltanext = 0;
3877             SSize_t fake_last_close = 0;
3878             I32 f = SCF_IN_DEFINE;
3879
3880             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3881             scan = regnext(scan);
3882             assert( OP(scan) == IFTHEN );
3883             DEBUG_PEEP("expect IFTHEN", scan, depth);
3884
3885             data_fake.last_closep= &fake_last_close;
3886             minlen = *minlenp;
3887             next = regnext(scan);
3888             scan = NEXTOPER(NEXTOPER(scan));
3889             DEBUG_PEEP("scan", scan, depth);
3890             DEBUG_PEEP("next", next, depth);
3891
3892             /* we suppose the run is continuous, last=next...
3893              * NOTE we dont use the return here! */
3894             (void)study_chunk(pRExC_state, &scan, &minlen,
3895                               &deltanext, next, &data_fake, stopparen,
3896                               recursed_depth, NULL, f, depth+1);
3897
3898             scan = next;
3899         } else
3900         if (
3901             OP(scan) == BRANCH  ||
3902             OP(scan) == BRANCHJ ||
3903             OP(scan) == IFTHEN
3904         ) {
3905             next = regnext(scan);
3906             code = OP(scan);
3907
3908             /* The op(next)==code check below is to see if we
3909              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
3910              * IFTHEN is special as it might not appear in pairs.
3911              * Not sure whether BRANCH-BRANCHJ is possible, regardless
3912              * we dont handle it cleanly. */
3913             if (OP(next) == code || code == IFTHEN) {
3914                 /* NOTE - There is similar code to this block below for
3915                  * handling TRIE nodes on a re-study.  If you change stuff here
3916                  * check there too. */
3917                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
3918                 regnode_ssc accum;
3919                 regnode * const startbranch=scan;
3920
3921                 if (flags & SCF_DO_SUBSTR) {
3922                     /* Cannot merge strings after this. */
3923                     scan_commit(pRExC_state, data, minlenp, is_inf);
3924                 }
3925
3926                 if (flags & SCF_DO_STCLASS)
3927                     ssc_init_zero(pRExC_state, &accum);
3928
3929                 while (OP(scan) == code) {
3930                     SSize_t deltanext, minnext, fake;
3931                     I32 f = 0;
3932                     regnode_ssc this_class;
3933
3934                     DEBUG_PEEP("Branch", scan, depth);
3935
3936                     num++;
3937                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3938                     if (data) {
3939                         data_fake.whilem_c = data->whilem_c;
3940                         data_fake.last_closep = data->last_closep;
3941                     }
3942                     else
3943                         data_fake.last_closep = &fake;
3944
3945                     data_fake.pos_delta = delta;
3946                     next = regnext(scan);
3947
3948                     scan = NEXTOPER(scan); /* everything */
3949                     if (code != BRANCH)    /* everything but BRANCH */
3950                         scan = NEXTOPER(scan);
3951
3952                     if (flags & SCF_DO_STCLASS) {
3953                         ssc_init(pRExC_state, &this_class);
3954                         data_fake.start_class = &this_class;
3955                         f = SCF_DO_STCLASS_AND;
3956                     }
3957                     if (flags & SCF_WHILEM_VISITED_POS)
3958                         f |= SCF_WHILEM_VISITED_POS;
3959
3960                     /* we suppose the run is continuous, last=next...*/
3961                     minnext = study_chunk(pRExC_state, &scan, minlenp,
3962                                       &deltanext, next, &data_fake, stopparen,
3963                                       recursed_depth, NULL, f,depth+1);
3964
3965                     if (min1 > minnext)
3966                         min1 = minnext;
3967                     if (deltanext == SSize_t_MAX) {
3968                         is_inf = is_inf_internal = 1;
3969                         max1 = SSize_t_MAX;
3970                     } else if (max1 < minnext + deltanext)
3971                         max1 = minnext + deltanext;
3972                     scan = next;
3973                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3974                         pars++;
3975                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3976                         if ( stopmin > minnext)
3977                             stopmin = min + min1;
3978                         flags &= ~SCF_DO_SUBSTR;
3979                         if (data)
3980                             data->flags |= SCF_SEEN_ACCEPT;
3981                     }
3982                     if (data) {
3983                         if (data_fake.flags & SF_HAS_EVAL)
3984                             data->flags |= SF_HAS_EVAL;
3985                         data->whilem_c = data_fake.whilem_c;
3986                     }
3987                     if (flags & SCF_DO_STCLASS)
3988                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
3989                 }
3990                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3991                     min1 = 0;
3992                 if (flags & SCF_DO_SUBSTR) {
3993                     data->pos_min += min1;
3994                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
3995                         data->pos_delta = SSize_t_MAX;
3996                     else
3997                         data->pos_delta += max1 - min1;
3998                     if (max1 != min1 || is_inf)
3999                         data->longest = &(data->longest_float);
4000                 }
4001                 min += min1;
4002                 if (delta == SSize_t_MAX
4003                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4004                     delta = SSize_t_MAX;
4005                 else
4006                     delta += max1 - min1;
4007                 if (flags & SCF_DO_STCLASS_OR) {
4008                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4009                     if (min1) {
4010                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4011                         flags &= ~SCF_DO_STCLASS;
4012                     }
4013                 }
4014                 else if (flags & SCF_DO_STCLASS_AND) {
4015                     if (min1) {
4016                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4017                         flags &= ~SCF_DO_STCLASS;
4018                     }
4019                     else {
4020                         /* Switch to OR mode: cache the old value of
4021                          * data->start_class */
4022                         INIT_AND_WITHP;
4023                         StructCopy(data->start_class, and_withp, regnode_ssc);
4024                         flags &= ~SCF_DO_STCLASS_AND;
4025                         StructCopy(&accum, data->start_class, regnode_ssc);
4026                         flags |= SCF_DO_STCLASS_OR;
4027                     }
4028                 }
4029
4030                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4031                         OP( startbranch ) == BRANCH )
4032                 {
4033                 /* demq.
4034
4035                    Assuming this was/is a branch we are dealing with: 'scan'
4036                    now points at the item that follows the branch sequence,
4037                    whatever it is. We now start at the beginning of the
4038                    sequence and look for subsequences of
4039
4040                    BRANCH->EXACT=>x1
4041                    BRANCH->EXACT=>x2
4042                    tail
4043
4044                    which would be constructed from a pattern like
4045                    /A|LIST|OF|WORDS/
4046
4047                    If we can find such a subsequence we need to turn the first
4048                    element into a trie and then add the subsequent branch exact
4049                    strings to the trie.
4050
4051                    We have two cases
4052
4053                      1. patterns where the whole set of branches can be
4054                         converted.
4055
4056                      2. patterns where only a subset can be converted.
4057
4058                    In case 1 we can replace the whole set with a single regop
4059                    for the trie. In case 2 we need to keep the start and end
4060                    branches so
4061
4062                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4063                      becomes BRANCH TRIE; BRANCH X;
4064
4065                   There is an additional case, that being where there is a
4066                   common prefix, which gets split out into an EXACT like node
4067                   preceding the TRIE node.
4068
4069                   If x(1..n)==tail then we can do a simple trie, if not we make
4070                   a "jump" trie, such that when we match the appropriate word
4071                   we "jump" to the appropriate tail node. Essentially we turn
4072                   a nested if into a case structure of sorts.
4073
4074                 */
4075
4076                     int made=0;
4077                     if (!re_trie_maxbuff) {
4078                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4079                         if (!SvIOK(re_trie_maxbuff))
4080                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4081                     }
4082                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4083                         regnode *cur;
4084                         regnode *first = (regnode *)NULL;
4085                         regnode *last = (regnode *)NULL;
4086                         regnode *tail = scan;
4087                         U8 trietype = 0;
4088                         U32 count=0;
4089
4090                         /* var tail is used because there may be a TAIL
4091                            regop in the way. Ie, the exacts will point to the
4092                            thing following the TAIL, but the last branch will
4093                            point at the TAIL. So we advance tail. If we
4094                            have nested (?:) we may have to move through several
4095                            tails.
4096                          */
4097
4098                         while ( OP( tail ) == TAIL ) {
4099                             /* this is the TAIL generated by (?:) */
4100                             tail = regnext( tail );
4101                         }
4102
4103
4104                         DEBUG_TRIE_COMPILE_r({
4105                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4106                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
4107                               (int)depth * 2 + 2, "",
4108                               "Looking for TRIE'able sequences. Tail node is: ",
4109                               SvPV_nolen_const( RExC_mysv )
4110                             );
4111                         });
4112
4113                         /*
4114
4115                             Step through the branches
4116                                 cur represents each branch,
4117                                 noper is the first thing to be matched as part
4118                                       of that branch
4119                                 noper_next is the regnext() of that node.
4120
4121                             We normally handle a case like this
4122                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4123                             support building with NOJUMPTRIE, which restricts
4124                             the trie logic to structures like /FOO|BAR/.
4125
4126                             If noper is a trieable nodetype then the branch is
4127                             a possible optimization target. If we are building
4128                             under NOJUMPTRIE then we require that noper_next is
4129                             the same as scan (our current position in the regex
4130                             program).
4131
4132                             Once we have two or more consecutive such branches
4133                             we can create a trie of the EXACT's contents and
4134                             stitch it in place into the program.
4135
4136                             If the sequence represents all of the branches in
4137                             the alternation we replace the entire thing with a
4138                             single TRIE node.
4139
4140                             Otherwise when it is a subsequence we need to
4141                             stitch it in place and replace only the relevant
4142                             branches. This means the first branch has to remain
4143                             as it is used by the alternation logic, and its
4144                             next pointer, and needs to be repointed at the item
4145                             on the branch chain following the last branch we
4146                             have optimized away.
4147
4148                             This could be either a BRANCH, in which case the
4149                             subsequence is internal, or it could be the item
4150                             following the branch sequence in which case the
4151                             subsequence is at the end (which does not
4152                             necessarily mean the first node is the start of the
4153                             alternation).
4154
4155                             TRIE_TYPE(X) is a define which maps the optype to a
4156                             trietype.
4157
4158                                 optype          |  trietype
4159                                 ----------------+-----------
4160                                 NOTHING         | NOTHING
4161                                 EXACT           | EXACT
4162                                 EXACTFU         | EXACTFU
4163                                 EXACTFU_SS      | EXACTFU
4164                                 EXACTFA         | EXACTFA
4165                                 EXACTL          | EXACTL
4166                                 EXACTFLU8       | EXACTFLU8
4167
4168
4169                         */
4170 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4171                        ? NOTHING                                            \
4172                        : ( EXACT == (X) )                                   \
4173                          ? EXACT                                            \
4174                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4175                            ? EXACTFU                                        \
4176                            : ( EXACTFA == (X) )                             \
4177                              ? EXACTFA                                      \
4178                              : ( EXACTL == (X) )                            \
4179                                ? EXACTL                                     \
4180                                : ( EXACTFLU8 == (X) )                        \
4181                                  ? EXACTFLU8                                 \
4182                                  : 0 )
4183
4184                         /* dont use tail as the end marker for this traverse */
4185                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4186                             regnode * const noper = NEXTOPER( cur );
4187                             U8 noper_type = OP( noper );
4188                             U8 noper_trietype = TRIE_TYPE( noper_type );
4189 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4190                             regnode * const noper_next = regnext( noper );
4191                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
4192                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
4193 #endif
4194
4195                             DEBUG_TRIE_COMPILE_r({
4196                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4197                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
4198                                    (int)depth * 2 + 2,"", SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4199
4200                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4201                                 PerlIO_printf( Perl_debug_log, " -> %s",
4202                                     SvPV_nolen_const(RExC_mysv));
4203
4204                                 if ( noper_next ) {
4205                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4206                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
4207                                     SvPV_nolen_const(RExC_mysv));
4208                                 }
4209                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
4210                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4211                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4212                                 );
4213                             });
4214
4215                             /* Is noper a trieable nodetype that can be merged
4216                              * with the current trie (if there is one)? */
4217                             if ( noper_trietype
4218                                   &&
4219                                   (
4220                                         ( noper_trietype == NOTHING)
4221                                         || ( trietype == NOTHING )
4222                                         || ( trietype == noper_trietype )
4223                                   )
4224 #ifdef NOJUMPTRIE
4225                                   && noper_next == tail
4226 #endif
4227                                   && count < U16_MAX)
4228                             {
4229                                 /* Handle mergable triable node Either we are
4230                                  * the first node in a new trieable sequence,
4231                                  * in which case we do some bookkeeping,
4232                                  * otherwise we update the end pointer. */
4233                                 if ( !first ) {
4234                                     first = cur;
4235                                     if ( noper_trietype == NOTHING ) {
4236 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4237                                         regnode * const noper_next = regnext( noper );
4238                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
4239                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4240 #endif
4241
4242                                         if ( noper_next_trietype ) {
4243                                             trietype = noper_next_trietype;
4244                                         } else if (noper_next_type)  {
4245                                             /* a NOTHING regop is 1 regop wide.
4246                                              * We need at least two for a trie
4247                                              * so we can't merge this in */
4248                                             first = NULL;
4249                                         }
4250                                     } else {
4251                                         trietype = noper_trietype;
4252                                     }
4253                                 } else {
4254                                     if ( trietype == NOTHING )
4255                                         trietype = noper_trietype;
4256                                     last = cur;
4257                                 }
4258                                 if (first)
4259                                     count++;
4260                             } /* end handle mergable triable node */
4261                             else {
4262                                 /* handle unmergable node -
4263                                  * noper may either be a triable node which can
4264                                  * not be tried together with the current trie,
4265                                  * or a non triable node */
4266                                 if ( last ) {
4267                                     /* If last is set and trietype is not
4268                                      * NOTHING then we have found at least two
4269                                      * triable branch sequences in a row of a
4270                                      * similar trietype so we can turn them
4271                                      * into a trie. If/when we allow NOTHING to
4272                                      * start a trie sequence this condition
4273                                      * will be required, and it isn't expensive
4274                                      * so we leave it in for now. */
4275                                     if ( trietype && trietype != NOTHING )
4276                                         make_trie( pRExC_state,
4277                                                 startbranch, first, cur, tail,
4278                                                 count, trietype, depth+1 );
4279                                     last = NULL; /* note: we clear/update
4280                                                     first, trietype etc below,
4281                                                     so we dont do it here */
4282                                 }
4283                                 if ( noper_trietype
4284 #ifdef NOJUMPTRIE
4285                                      && noper_next == tail
4286 #endif
4287                                 ){
4288                                     /* noper is triable, so we can start a new
4289                                      * trie sequence */
4290                                     count = 1;
4291                                     first = cur;
4292                                     trietype = noper_trietype;
4293                                 } else if (first) {
4294                                     /* if we already saw a first but the
4295                                      * current node is not triable then we have
4296                                      * to reset the first information. */
4297                                     count = 0;
4298                                     first = NULL;
4299                                     trietype = 0;
4300                                 }
4301                             } /* end handle unmergable node */
4302                         } /* loop over branches */
4303                         DEBUG_TRIE_COMPILE_r({
4304                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4305                             PerlIO_printf( Perl_debug_log,
4306                               "%*s- %s (%d) <SCAN FINISHED>\n",
4307                               (int)depth * 2 + 2,
4308                               "", SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4309
4310                         });
4311                         if ( last && trietype ) {
4312                             if ( trietype != NOTHING ) {
4313                                 /* the last branch of the sequence was part of
4314                                  * a trie, so we have to construct it here
4315                                  * outside of the loop */
4316                                 made= make_trie( pRExC_state, startbranch,
4317                                                  first, scan, tail, count,
4318                                                  trietype, depth+1 );
4319 #ifdef TRIE_STUDY_OPT
4320                                 if ( ((made == MADE_EXACT_TRIE &&
4321                                      startbranch == first)
4322                                      || ( first_non_open == first )) &&
4323                                      depth==0 ) {
4324                                     flags |= SCF_TRIE_RESTUDY;
4325                                     if ( startbranch == first
4326                                          && scan == tail )
4327                                     {
4328                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4329                                     }
4330                                 }
4331 #endif
4332                             } else {
4333                                 /* at this point we know whatever we have is a
4334                                  * NOTHING sequence/branch AND if 'startbranch'
4335                                  * is 'first' then we can turn the whole thing
4336                                  * into a NOTHING
4337                                  */
4338                                 if ( startbranch == first ) {
4339                                     regnode *opt;
4340                                     /* the entire thing is a NOTHING sequence,
4341                                      * something like this: (?:|) So we can
4342                                      * turn it into a plain NOTHING op. */
4343                                     DEBUG_TRIE_COMPILE_r({
4344                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4345                                         PerlIO_printf( Perl_debug_log,
4346                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
4347                                           "", SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4348
4349                                     });
4350                                     OP(startbranch)= NOTHING;
4351                                     NEXT_OFF(startbranch)= tail - startbranch;
4352                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4353                                         OP(opt)= OPTIMIZED;
4354                                 }
4355                             }
4356                         } /* end if ( last) */
4357                     } /* TRIE_MAXBUF is non zero */
4358
4359                 } /* do trie */
4360
4361             }
4362             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4363                 scan = NEXTOPER(NEXTOPER(scan));
4364             } else                      /* single branch is optimized. */
4365                 scan = NEXTOPER(scan);
4366             continue;
4367         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
4368             I32 paren = 0;
4369             regnode *start = NULL;
4370             regnode *end = NULL;
4371             U32 my_recursed_depth= recursed_depth;
4372
4373
4374             if (OP(scan) != SUSPEND) { /* GOSUB/GOSTART */
4375                 /* Do setup, note this code has side effects beyond
4376                  * the rest of this block. Specifically setting
4377                  * RExC_recurse[] must happen at least once during
4378                  * study_chunk(). */
4379                 if (OP(scan) == GOSUB) {
4380                     paren = ARG(scan);
4381                     RExC_recurse[ARG2L(scan)] = scan;
4382                     start = RExC_open_parens[paren-1];
4383                     end   = RExC_close_parens[paren-1];
4384                 } else {
4385                     start = RExC_rxi->program + 1;
4386                     end   = RExC_opend;
4387                 }
4388                 /* NOTE we MUST always execute the above code, even
4389                  * if we do nothing with a GOSUB/GOSTART */
4390                 if (
4391                     ( flags & SCF_IN_DEFINE )
4392                     ||
4393                     (
4394                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4395                         &&
4396                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4397                     )
4398                 ) {
4399                     /* no need to do anything here if we are in a define. */
4400                     /* or we are after some kind of infinite construct
4401                      * so we can skip recursing into this item.
4402                      * Since it is infinite we will not change the maxlen
4403                      * or delta, and if we miss something that might raise
4404                      * the minlen it will merely pessimise a little.
4405                      *
4406                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4407                      * might result in a minlen of 1 and not of 4,
4408                      * but this doesn't make us mismatch, just try a bit
4409                      * harder than we should.
4410                      * */
4411                     scan= regnext(scan);
4412                     continue;
4413                 }
4414
4415                 if (
4416                     !recursed_depth
4417                     ||
4418                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4419                 ) {
4420                     /* it is quite possible that there are more efficient ways
4421                      * to do this. We maintain a bitmap per level of recursion
4422                      * of which patterns we have entered so we can detect if a
4423                      * pattern creates a possible infinite loop. When we
4424                      * recurse down a level we copy the previous levels bitmap
4425                      * down. When we are at recursion level 0 we zero the top
4426                      * level bitmap. It would be nice to implement a different
4427                      * more efficient way of doing this. In particular the top
4428                      * level bitmap may be unnecessary.
4429                      */
4430                     if (!recursed_depth) {
4431                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4432                     } else {
4433                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4434                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4435                              RExC_study_chunk_recursed_bytes, U8);
4436                     }
4437                     /* we havent recursed into this paren yet, so recurse into it */
4438                     DEBUG_STUDYDATA("set:", data,depth);
4439                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4440                     my_recursed_depth= recursed_depth + 1;
4441                 } else {
4442                     DEBUG_STUDYDATA("inf:", data,depth);
4443                     /* some form of infinite recursion, assume infinite length
4444                      * */
4445                     if (flags & SCF_DO_SUBSTR) {
4446                         scan_commit(pRExC_state, data, minlenp, is_inf);
4447                         data->longest = &(data->longest_float);
4448                     }
4449                     is_inf = is_inf_internal = 1;
4450                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4451                         ssc_anything(data->start_class);
4452                     flags &= ~SCF_DO_STCLASS;
4453
4454                     start= NULL; /* reset start so we dont recurse later on. */
4455                 }
4456             } else {
4457                 paren = stopparen;
4458                 start = scan + 2;
4459                 end = regnext(scan);
4460             }
4461             if (start) {
4462                 scan_frame *newframe;
4463                 assert(end);
4464                 if (!RExC_frame_last) {
4465                     Newxz(newframe, 1, scan_frame);
4466                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4467                     RExC_frame_head= newframe;
4468                     RExC_frame_count++;
4469                 } else if (!RExC_frame_last->next_frame) {
4470                     Newxz(newframe,1,scan_frame);
4471                     RExC_frame_last->next_frame= newframe;
4472                     newframe->prev_frame= RExC_frame_last;
4473                     RExC_frame_count++;
4474                 } else {
4475                     newframe= RExC_frame_last->next_frame;
4476                 }
4477                 RExC_frame_last= newframe;
4478
4479                 newframe->next_regnode = regnext(scan);
4480                 newframe->last_regnode = last;
4481                 newframe->stopparen = stopparen;
4482                 newframe->prev_recursed_depth = recursed_depth;
4483                 newframe->this_prev_frame= frame;
4484
4485                 DEBUG_STUDYDATA("frame-new:",data,depth);
4486                 DEBUG_PEEP("fnew", scan, depth);
4487
4488                 frame = newframe;
4489                 scan =  start;
4490                 stopparen = paren;
4491                 last = end;
4492                 depth = depth + 1;
4493                 recursed_depth= my_recursed_depth;
4494
4495                 continue;
4496             }
4497         }
4498         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4499             SSize_t l = STR_LEN(scan);
4500             UV uc;
4501             if (UTF) {
4502                 const U8 * const s = (U8*)STRING(scan);
4503                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4504                 l = utf8_length(s, s + l);
4505             } else {
4506                 uc = *((U8*)STRING(scan));
4507             }
4508             min += l;
4509             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4510                 /* The code below prefers earlier match for fixed
4511                    offset, later match for variable offset.  */
4512                 if (data->last_end == -1) { /* Update the start info. */
4513                     data->last_start_min = data->pos_min;
4514                     data->last_start_max = is_inf
4515                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4516                 }
4517                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4518                 if (UTF)
4519                     SvUTF8_on(data->last_found);
4520                 {
4521                     SV * const sv = data->last_found;
4522                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4523                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4524                     if (mg && mg->mg_len >= 0)
4525                         mg->mg_len += utf8_length((U8*)STRING(scan),
4526                                               (U8*)STRING(scan)+STR_LEN(scan));
4527                 }
4528                 data->last_end = data->pos_min + l;
4529                 data->pos_min += l; /* As in the first entry. */
4530                 data->flags &= ~SF_BEFORE_EOL;
4531             }
4532
4533             /* ANDing the code point leaves at most it, and not in locale, and
4534              * can't match null string */
4535             if (flags & SCF_DO_STCLASS_AND) {
4536                 ssc_cp_and(data->start_class, uc);
4537                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4538                 ssc_clear_locale(data->start_class);
4539             }
4540             else if (flags & SCF_DO_STCLASS_OR) {
4541                 ssc_add_cp(data->start_class, uc);
4542                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4543
4544                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4545                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4546             }
4547             flags &= ~SCF_DO_STCLASS;
4548         }
4549         else if (PL_regkind[OP(scan)] == EXACT) {
4550             /* But OP != EXACT!, so is EXACTFish */
4551             SSize_t l = STR_LEN(scan);
4552             const U8 * s = (U8*)STRING(scan);
4553
4554             /* Search for fixed substrings supports EXACT only. */
4555             if (flags & SCF_DO_SUBSTR) {
4556                 assert(data);
4557                 scan_commit(pRExC_state, data, minlenp, is_inf);
4558             }
4559             if (UTF) {
4560                 l = utf8_length(s, s + l);
4561             }
4562             if (unfolded_multi_char) {
4563                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4564             }
4565             min += l - min_subtract;
4566             assert (min >= 0);
4567             delta += min_subtract;
4568             if (flags & SCF_DO_SUBSTR) {
4569                 data->pos_min += l - min_subtract;
4570                 if (data->pos_min < 0) {
4571                     data->pos_min = 0;
4572                 }
4573                 data->pos_delta += min_subtract;
4574                 if (min_subtract) {
4575                     data->longest = &(data->longest_float);
4576                 }
4577             }
4578
4579             if (flags & SCF_DO_STCLASS) {
4580                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4581
4582                 assert(EXACTF_invlist);
4583                 if (flags & SCF_DO_STCLASS_AND) {
4584                     if (OP(scan) != EXACTFL)
4585                         ssc_clear_locale(data->start_class);
4586                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4587                     ANYOF_POSIXL_ZERO(data->start_class);
4588                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4589                 }
4590                 else {  /* SCF_DO_STCLASS_OR */
4591                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4592                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4593
4594                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4595                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4596                 }
4597                 flags &= ~SCF_DO_STCLASS;
4598                 SvREFCNT_dec(EXACTF_invlist);
4599             }
4600         }
4601         else if (REGNODE_VARIES(OP(scan))) {
4602             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4603             I32 fl = 0, f = flags;
4604             regnode * const oscan = scan;
4605             regnode_ssc this_class;
4606             regnode_ssc *oclass = NULL;
4607             I32 next_is_eval = 0;
4608
4609             switch (PL_regkind[OP(scan)]) {
4610             case WHILEM:                /* End of (?:...)* . */
4611                 scan = NEXTOPER(scan);
4612                 goto finish;
4613             case PLUS:
4614                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4615                     next = NEXTOPER(scan);
4616                     if (OP(next) == EXACT
4617                         || OP(next) == EXACTL
4618                         || (flags & SCF_DO_STCLASS))
4619                     {
4620                         mincount = 1;
4621                         maxcount = REG_INFTY;
4622                         next = regnext(scan);
4623                         scan = NEXTOPER(scan);
4624                         goto do_curly;
4625                     }
4626                 }
4627                 if (flags & SCF_DO_SUBSTR)
4628                     data->pos_min++;
4629                 min++;
4630                 /* FALLTHROUGH */
4631             case STAR:
4632                 if (flags & SCF_DO_STCLASS) {
4633                     mincount = 0;
4634                     maxcount = REG_INFTY;
4635                     next = regnext(scan);
4636                     scan = NEXTOPER(scan);
4637                     goto do_curly;
4638                 }
4639                 if (flags & SCF_DO_SUBSTR) {
4640                     scan_commit(pRExC_state, data, minlenp, is_inf);
4641                     /* Cannot extend fixed substrings */
4642                     data->longest = &(data->longest_float);
4643                 }
4644                 is_inf = is_inf_internal = 1;
4645                 scan = regnext(scan);
4646                 goto optimize_curly_tail;
4647             case CURLY:
4648                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4649                     && (scan->flags == stopparen))
4650                 {
4651                     mincount = 1;
4652                     maxcount = 1;
4653                 } else {
4654                     mincount = ARG1(scan);
4655                     maxcount = ARG2(scan);
4656                 }
4657                 next = regnext(scan);
4658                 if (OP(scan) == CURLYX) {
4659                     I32 lp = (data ? *(data->last_closep) : 0);
4660                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
4661                 }
4662                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4663                 next_is_eval = (OP(scan) == EVAL);
4664               do_curly:
4665                 if (flags & SCF_DO_SUBSTR) {
4666                     if (mincount == 0)
4667                         scan_commit(pRExC_state, data, minlenp, is_inf);
4668                     /* Cannot extend fixed substrings */
4669                     pos_before = data->pos_min;
4670                 }
4671                 if (data) {
4672                     fl = data->flags;
4673                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
4674                     if (is_inf)
4675                         data->flags |= SF_IS_INF;
4676                 }
4677                 if (flags & SCF_DO_STCLASS) {
4678                     ssc_init(pRExC_state, &this_class);
4679                     oclass = data->start_class;
4680                     data->start_class = &this_class;
4681                     f |= SCF_DO_STCLASS_AND;
4682                     f &= ~SCF_DO_STCLASS_OR;
4683                 }
4684                 /* Exclude from super-linear cache processing any {n,m}
4685                    regops for which the combination of input pos and regex
4686                    pos is not enough information to determine if a match
4687                    will be possible.
4688
4689                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
4690                    regex pos at the \s*, the prospects for a match depend not
4691                    only on the input position but also on how many (bar\s*)
4692                    repeats into the {4,8} we are. */
4693                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
4694                     f &= ~SCF_WHILEM_VISITED_POS;
4695
4696                 /* This will finish on WHILEM, setting scan, or on NULL: */
4697                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
4698                                   last, data, stopparen, recursed_depth, NULL,
4699                                   (mincount == 0
4700                                    ? (f & ~SCF_DO_SUBSTR)
4701                                    : f)
4702                                   ,depth+1);
4703
4704                 if (flags & SCF_DO_STCLASS)
4705                     data->start_class = oclass;
4706                 if (mincount == 0 || minnext == 0) {
4707                     if (flags & SCF_DO_STCLASS_OR) {
4708                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4709                     }
4710                     else if (flags & SCF_DO_STCLASS_AND) {
4711                         /* Switch to OR mode: cache the old value of
4712                          * data->start_class */
4713                         INIT_AND_WITHP;
4714                         StructCopy(data->start_class, and_withp, regnode_ssc);
4715                         flags &= ~SCF_DO_STCLASS_AND;
4716                         StructCopy(&this_class, data->start_class, regnode_ssc);
4717                         flags |= SCF_DO_STCLASS_OR;
4718                         ANYOF_FLAGS(data->start_class)
4719                                                 |= SSC_MATCHES_EMPTY_STRING;
4720                     }
4721                 } else {                /* Non-zero len */
4722                     if (flags & SCF_DO_STCLASS_OR) {
4723                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4724                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4725                     }
4726                     else if (flags & SCF_DO_STCLASS_AND)
4727                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4728                     flags &= ~SCF_DO_STCLASS;
4729                 }
4730                 if (!scan)              /* It was not CURLYX, but CURLY. */
4731                     scan = next;
4732                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
4733                     /* ? quantifier ok, except for (?{ ... }) */
4734                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
4735                     && (minnext == 0) && (deltanext == 0)
4736                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
4737                     && maxcount <= REG_INFTY/3) /* Complement check for big
4738                                                    count */
4739                 {
4740                     /* Fatal warnings may leak the regexp without this: */
4741                     SAVEFREESV(RExC_rx_sv);
4742                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
4743                         "Quantifier unexpected on zero-length expression "
4744                         "in regex m/%"UTF8f"/",
4745                          UTF8fARG(UTF, RExC_end - RExC_precomp,
4746                                   RExC_precomp));
4747                     (void)ReREFCNT_inc(RExC_rx_sv);
4748                 }
4749
4750                 min += minnext * mincount;
4751                 is_inf_internal |= deltanext == SSize_t_MAX
4752                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
4753                 is_inf |= is_inf_internal;
4754                 if (is_inf) {
4755                     delta = SSize_t_MAX;
4756                 } else {
4757                     delta += (minnext + deltanext) * maxcount
4758                              - minnext * mincount;
4759                 }
4760                 /* Try powerful optimization CURLYX => CURLYN. */
4761                 if (  OP(oscan) == CURLYX && data
4762                       && data->flags & SF_IN_PAR
4763                       && !(data->flags & SF_HAS_EVAL)
4764                       && !deltanext && minnext == 1 ) {
4765                     /* Try to optimize to CURLYN.  */
4766                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
4767                     regnode * const nxt1 = nxt;
4768 #ifdef DEBUGGING
4769                     regnode *nxt2;
4770 #endif
4771
4772                     /* Skip open. */
4773                     nxt = regnext(nxt);
4774                     if (!REGNODE_SIMPLE(OP(nxt))
4775                         && !(PL_regkind[OP(nxt)] == EXACT
4776                              && STR_LEN(nxt) == 1))
4777                         goto nogo;
4778 #ifdef DEBUGGING
4779                     nxt2 = nxt;
4780 #endif
4781                     nxt = regnext(nxt);
4782                     if (OP(nxt) != CLOSE)
4783                         goto nogo;
4784                     if (RExC_open_parens) {
4785                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
4786                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
4787                     }
4788                     /* Now we know that nxt2 is the only contents: */
4789                     oscan->flags = (U8)ARG(nxt);
4790                     OP(oscan) = CURLYN;
4791                     OP(nxt1) = NOTHING; /* was OPEN. */
4792
4793 #ifdef DEBUGGING
4794                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
4795                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
4796                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
4797                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
4798                     OP(nxt + 1) = OPTIMIZED; /* was count. */
4799                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
4800 #endif
4801                 }
4802               nogo:
4803
4804                 /* Try optimization CURLYX => CURLYM. */
4805                 if (  OP(oscan) == CURLYX && data
4806                       && !(data->flags & SF_HAS_PAR)
4807                       && !(data->flags & SF_HAS_EVAL)
4808                       && !deltanext     /* atom is fixed width */
4809                       && minnext != 0   /* CURLYM can't handle zero width */
4810
4811                          /* Nor characters whose fold at run-time may be
4812                           * multi-character */
4813                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
4814                 ) {
4815                     /* XXXX How to optimize if data == 0? */
4816                     /* Optimize to a simpler form.  */
4817                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
4818                     regnode *nxt2;
4819
4820                     OP(oscan) = CURLYM;
4821                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
4822                             && (OP(nxt2) != WHILEM))
4823                         nxt = nxt2;
4824                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
4825                     /* Need to optimize away parenths. */
4826                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
4827                         /* Set the parenth number.  */
4828                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
4829
4830                         oscan->flags = (U8)ARG(nxt);
4831                         if (RExC_open_parens) {
4832                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
4833                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
4834                         }
4835                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
4836                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
4837
4838 #ifdef DEBUGGING
4839                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
4840                         OP(nxt + 1) = OPTIMIZED; /* was count. */
4841                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
4842                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
4843 #endif
4844 #if 0
4845                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
4846                             regnode *nnxt = regnext(nxt1);
4847                             if (nnxt == nxt) {
4848                                 if (reg_off_by_arg[OP(nxt1)])
4849                                     ARG_SET(nxt1, nxt2 - nxt1);
4850                                 else if (nxt2 - nxt1 < U16_MAX)
4851                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
4852                                 else
4853                                     OP(nxt) = NOTHING;  /* Cannot beautify */
4854                             }
4855                             nxt1 = nnxt;
4856                         }
4857 #endif
4858                         /* Optimize again: */
4859                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4860                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
4861                     }
4862                     else
4863                         oscan->flags = 0;
4864                 }
4865                 else if ((OP(oscan) == CURLYX)
4866                          && (flags & SCF_WHILEM_VISITED_POS)
4867                          /* See the comment on a similar expression above.
4868                             However, this time it's not a subexpression
4869                             we care about, but the expression itself. */
4870                          && (maxcount == REG_INFTY)
4871                          && data && ++data->whilem_c < 16) {
4872                     /* This stays as CURLYX, we can put the count/of pair. */
4873                     /* Find WHILEM (as in regexec.c) */
4874                     regnode *nxt = oscan + NEXT_OFF(oscan);
4875
4876                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4877                         nxt += ARG(nxt);
4878                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4879                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4880                 }
4881                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4882                     pars++;
4883                 if (flags & SCF_DO_SUBSTR) {
4884                     SV *last_str = NULL;
4885                     STRLEN last_chrs = 0;
4886                     int counted = mincount != 0;
4887
4888                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
4889                                                                   string. */
4890                         SSize_t b = pos_before >= data->last_start_min
4891                             ? pos_before : data->last_start_min;
4892                         STRLEN l;
4893                         const char * const s = SvPV_const(data->last_found, l);
4894                         SSize_t old = b - data->last_start_min;
4895
4896                         if (UTF)
4897                             old = utf8_hop((U8*)s, old) - (U8*)s;
4898                         l -= old;
4899                         /* Get the added string: */
4900                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4901                         last_chrs = UTF ? utf8_length((U8*)(s + old),
4902                                             (U8*)(s + old + l)) : l;
4903                         if (deltanext == 0 && pos_before == b) {
4904                             /* What was added is a constant string */
4905                             if (mincount > 1) {
4906
4907                                 SvGROW(last_str, (mincount * l) + 1);
4908                                 repeatcpy(SvPVX(last_str) + l,
4909                                           SvPVX_const(last_str), l,
4910                                           mincount - 1);
4911                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4912                                 /* Add additional parts. */
4913                                 SvCUR_set(data->last_found,
4914                                           SvCUR(data->last_found) - l);
4915                                 sv_catsv(data->last_found, last_str);
4916                                 {
4917                                     SV * sv = data->last_found;
4918                                     MAGIC *mg =
4919                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4920                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4921                                     if (mg && mg->mg_len >= 0)
4922                                         mg->mg_len += last_chrs * (mincount-1);
4923                                 }
4924                                 last_chrs *= mincount;
4925                                 data->last_end += l * (mincount - 1);
4926                             }
4927                         } else {
4928                             /* start offset must point into the last copy */
4929                             data->last_start_min += minnext * (mincount - 1);
4930                             data->last_start_max =
4931                               is_inf
4932                                ? SSize_t_MAX
4933                                : data->last_start_max +
4934                                  (maxcount - 1) * (minnext + data->pos_delta);
4935                         }
4936                     }
4937                     /* It is counted once already... */
4938                     data->pos_min += minnext * (mincount - counted);
4939 #if 0
4940 PerlIO_printf(Perl_debug_log, "counted=%"UVuf" deltanext=%"UVuf
4941                               " SSize_t_MAX=%"UVuf" minnext=%"UVuf
4942                               " maxcount=%"UVuf" mincount=%"UVuf"\n",
4943     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
4944     (UV)mincount);
4945 if (deltanext != SSize_t_MAX)
4946 PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n",
4947     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
4948           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
4949 #endif
4950                     if (deltanext == SSize_t_MAX
4951                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
4952                         data->pos_delta = SSize_t_MAX;
4953                     else
4954                         data->pos_delta += - counted * deltanext +
4955                         (minnext + deltanext) * maxcount - minnext * mincount;
4956                     if (mincount != maxcount) {
4957                          /* Cannot extend fixed substrings found inside
4958                             the group.  */
4959                         scan_commit(pRExC_state, data, minlenp, is_inf);
4960                         if (mincount && last_str) {
4961                             SV * const sv = data->last_found;
4962                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4963                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4964
4965                             if (mg)
4966                                 mg->mg_len = -1;
4967                             sv_setsv(sv, last_str);
4968                             data->last_end = data->pos_min;
4969                             data->last_start_min = data->pos_min - last_chrs;
4970                             data->last_start_max = is_inf
4971                                 ? SSize_t_MAX
4972                                 : data->pos_min + data->pos_delta - last_chrs;
4973                         }
4974                         data->longest = &(data->longest_float);
4975                     }
4976                     SvREFCNT_dec(last_str);
4977                 }
4978                 if (data && (fl & SF_HAS_EVAL))
4979                     data->flags |= SF_HAS_EVAL;
4980               optimize_curly_tail:
4981                 if (OP(oscan) != CURLYX) {
4982                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4983                            && NEXT_OFF(next))
4984                         NEXT_OFF(oscan) += NEXT_OFF(next);
4985                 }
4986                 continue;
4987
4988             default:
4989 #ifdef DEBUGGING
4990                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
4991                                                                     OP(scan));
4992 #endif
4993             case REF:
4994             case CLUMP:
4995                 if (flags & SCF_DO_SUBSTR) {
4996                     /* Cannot expect anything... */
4997                     scan_commit(pRExC_state, data, minlenp, is_inf);
4998                     data->longest = &(data->longest_float);
4999                 }
5000                 is_inf = is_inf_internal = 1;
5001                 if (flags & SCF_DO_STCLASS_OR) {
5002                     if (OP(scan) == CLUMP) {
5003                         /* Actually is any start char, but very few code points
5004                          * aren't start characters */
5005                         ssc_match_all_cp(data->start_class);
5006                     }
5007                     else {
5008                         ssc_anything(data->start_class);
5009                     }
5010                 }
5011                 flags &= ~SCF_DO_STCLASS;
5012                 break;
5013             }
5014         }
5015         else if (OP(scan) == LNBREAK) {
5016             if (flags & SCF_DO_STCLASS) {
5017                 if (flags & SCF_DO_STCLASS_AND) {
5018                     ssc_intersection(data->start_class,
5019                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5020                     ssc_clear_locale(data->start_class);
5021                     ANYOF_FLAGS(data->start_class)
5022                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5023                 }
5024                 else if (flags & SCF_DO_STCLASS_OR) {
5025                     ssc_union(data->start_class,
5026                               PL_XPosix_ptrs[_CC_VERTSPACE],
5027                               FALSE);
5028                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5029
5030                     /* See commit msg for
5031                      * 749e076fceedeb708a624933726e7989f2302f6a */
5032                     ANYOF_FLAGS(data->start_class)
5033                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5034                 }
5035                 flags &= ~SCF_DO_STCLASS;
5036             }
5037             min++;
5038             if (delta != SSize_t_MAX)
5039                 delta++;    /* Because of the 2 char string cr-lf */
5040             if (flags & SCF_DO_SUBSTR) {
5041                 /* Cannot expect anything... */
5042                 scan_commit(pRExC_state, data, minlenp, is_inf);
5043                 data->pos_min += 1;
5044                 data->pos_delta += 1;
5045                 data->longest = &(data->longest_float);
5046             }
5047         }
5048         else if (REGNODE_SIMPLE(OP(scan))) {
5049
5050             if (flags & SCF_DO_SUBSTR) {
5051                 scan_commit(pRExC_state, data, minlenp, is_inf);
5052                 data->pos_min++;
5053             }
5054             min++;
5055             if (flags & SCF_DO_STCLASS) {
5056                 bool invert = 0;
5057                 SV* my_invlist = NULL;
5058                 U8 namedclass;
5059
5060                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5061                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5062
5063                 /* Some of the logic below assumes that switching
5064                    locale on will only add false positives. */
5065                 switch (OP(scan)) {
5066
5067                 default:
5068 #ifdef DEBUGGING
5069                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5070                                                                      OP(scan));
5071 #endif
5072                 case CANY:
5073                 case SANY:
5074                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5075                         ssc_match_all_cp(data->start_class);
5076                     break;
5077
5078                 case REG_ANY:
5079                     {
5080                         SV* REG_ANY_invlist = _new_invlist(2);
5081                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5082                                                             '\n');
5083                         if (flags & SCF_DO_STCLASS_OR) {
5084                             ssc_union(data->start_class,
5085                                       REG_ANY_invlist,
5086                                       TRUE /* TRUE => invert, hence all but \n
5087                                             */
5088                                       );
5089                         }
5090                         else if (flags & SCF_DO_STCLASS_AND) {
5091                             ssc_intersection(data->start_class,
5092                                              REG_ANY_invlist,
5093                                              TRUE  /* TRUE => invert */
5094                                              );
5095                             ssc_clear_locale(data->start_class);
5096                         }
5097                         SvREFCNT_dec_NN(REG_ANY_invlist);
5098                     }
5099                     break;
5100
5101                 case ANYOFL:
5102                 case ANYOF:
5103                     if (flags & SCF_DO_STCLASS_AND)
5104                         ssc_and(pRExC_state, data->start_class,
5105                                 (regnode_charclass *) scan);
5106                     else
5107                         ssc_or(pRExC_state, data->start_class,
5108                                                           (regnode_charclass *) scan);
5109                     break;
5110
5111                 case NPOSIXL:
5112                     invert = 1;
5113                     /* FALLTHROUGH */
5114
5115                 case POSIXL:
5116                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5117                     if (flags & SCF_DO_STCLASS_AND) {
5118                         bool was_there = cBOOL(
5119                                           ANYOF_POSIXL_TEST(data->start_class,
5120                                                                  namedclass));
5121                         ANYOF_POSIXL_ZERO(data->start_class);
5122                         if (was_there) {    /* Do an AND */
5123                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5124                         }
5125                         /* No individual code points can now match */
5126                         data->start_class->invlist
5127                                                 = sv_2mortal(_new_invlist(0));
5128                     }
5129                     else {
5130                         int complement = namedclass + ((invert) ? -1 : 1);
5131
5132                         assert(flags & SCF_DO_STCLASS_OR);
5133
5134                         /* If the complement of this class was already there,
5135                          * the result is that they match all code points,
5136                          * (\d + \D == everything).  Remove the classes from
5137                          * future consideration.  Locale is not relevant in
5138                          * this case */
5139                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5140                             ssc_match_all_cp(data->start_class);
5141                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5142                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5143                         }
5144                         else {  /* The usual case; just add this class to the
5145                                    existing set */
5146                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5147                         }
5148                     }
5149                     break;
5150
5151                 case NPOSIXA:   /* For these, we always know the exact set of
5152                                    what's matched */
5153                     invert = 1;
5154                     /* FALLTHROUGH */
5155                 case POSIXA:
5156                     if (FLAGS(scan) == _CC_ASCII) {
5157                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5158                     }
5159                     else {
5160                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5161                                               PL_XPosix_ptrs[_CC_ASCII],
5162                                               &my_invlist);
5163                     }
5164                     goto join_posix;
5165
5166                 case NPOSIXD:
5167                 case NPOSIXU:
5168                     invert = 1;
5169                     /* FALLTHROUGH */
5170                 case POSIXD:
5171                 case POSIXU:
5172                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5173
5174                     /* NPOSIXD matches all upper Latin1 code points unless the
5175                      * target string being matched is UTF-8, which is
5176                      * unknowable until match time.  Since we are going to
5177                      * invert, we want to get rid of all of them so that the
5178                      * inversion will match all */
5179                     if (OP(scan) == NPOSIXD) {
5180                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5181                                           &my_invlist);
5182                     }
5183
5184                   join_posix:
5185
5186                     if (flags & SCF_DO_STCLASS_AND) {
5187                         ssc_intersection(data->start_class, my_invlist, invert);
5188                         ssc_clear_locale(data->start_class);
5189                     }
5190                     else {
5191                         assert(flags & SCF_DO_STCLASS_OR);
5192                         ssc_union(data->start_class, my_invlist, invert);
5193                     }
5194                     SvREFCNT_dec(my_invlist);
5195                 }
5196                 if (flags & SCF_DO_STCLASS_OR)
5197                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5198                 flags &= ~SCF_DO_STCLASS;
5199             }
5200         }
5201         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5202             data->flags |= (OP(scan) == MEOL
5203                             ? SF_BEFORE_MEOL
5204                             : SF_BEFORE_SEOL);
5205             scan_commit(pRExC_state, data, minlenp, is_inf);
5206
5207         }
5208         else if (  PL_regkind[OP(scan)] == BRANCHJ
5209                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5210                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5211                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5212         {
5213             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5214                 || OP(scan) == UNLESSM )
5215             {
5216                 /* Negative Lookahead/lookbehind
5217                    In this case we can't do fixed string optimisation.
5218                 */
5219
5220                 SSize_t deltanext, minnext, fake = 0;
5221                 regnode *nscan;
5222                 regnode_ssc intrnl;
5223                 int f = 0;
5224
5225                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5226                 if (data) {
5227                     data_fake.whilem_c = data->whilem_c;
5228                     data_fake.last_closep = data->last_closep;
5229                 }
5230                 else
5231                     data_fake.last_closep = &fake;
5232                 data_fake.pos_delta = delta;
5233                 if ( flags & SCF_DO_STCLASS && !scan->flags
5234                      && OP(scan) == IFMATCH ) { /* Lookahead */
5235                     ssc_init(pRExC_state, &intrnl);
5236                     data_fake.start_class = &intrnl;
5237                     f |= SCF_DO_STCLASS_AND;
5238                 }
5239                 if (flags & SCF_WHILEM_VISITED_POS)
5240                     f |= SCF_WHILEM_VISITED_POS;
5241                 next = regnext(scan);
5242                 nscan = NEXTOPER(NEXTOPER(scan));
5243                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5244                                       last, &data_fake, stopparen,
5245                                       recursed_depth, NULL, f, depth+1);
5246                 if (scan->flags) {
5247                     if (deltanext) {
5248                         FAIL("Variable length lookbehind not implemented");
5249                     }
5250                     else if (minnext > (I32)U8_MAX) {
5251                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5252                               (UV)U8_MAX);
5253                     }
5254                     scan->flags = (U8)minnext;
5255                 }
5256                 if (data) {
5257                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5258                         pars++;
5259                     if (data_fake.flags & SF_HAS_EVAL)
5260                         data->flags |= SF_HAS_EVAL;
5261                     data->whilem_c = data_fake.whilem_c;
5262                 }
5263                 if (f & SCF_DO_STCLASS_AND) {
5264                     if (flags & SCF_DO_STCLASS_OR) {
5265                         /* OR before, AND after: ideally we would recurse with
5266                          * data_fake to get the AND applied by study of the
5267                          * remainder of the pattern, and then derecurse;
5268                          * *** HACK *** for now just treat as "no information".
5269                          * See [perl #56690].
5270                          */
5271                         ssc_init(pRExC_state, data->start_class);
5272                     }  else {
5273                         /* AND before and after: combine and continue.  These
5274                          * assertions are zero-length, so can match an EMPTY
5275                          * string */
5276                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5277                         ANYOF_FLAGS(data->start_class)
5278                                                    |= SSC_MATCHES_EMPTY_STRING;
5279                     }
5280                 }
5281             }
5282 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5283             else {
5284                 /* Positive Lookahead/lookbehind
5285                    In this case we can do fixed string optimisation,
5286                    but we must be careful about it. Note in the case of
5287                    lookbehind the positions will be offset by the minimum
5288                    length of the pattern, something we won't know about
5289                    until after the recurse.
5290                 */
5291                 SSize_t deltanext, fake = 0;
5292                 regnode *nscan;
5293                 regnode_ssc intrnl;
5294                 int f = 0;
5295                 /* We use SAVEFREEPV so that when the full compile
5296                     is finished perl will clean up the allocated
5297                     minlens when it's all done. This way we don't
5298                     have to worry about freeing them when we know
5299                     they wont be used, which would be a pain.
5300                  */
5301                 SSize_t *minnextp;
5302                 Newx( minnextp, 1, SSize_t );
5303                 SAVEFREEPV(minnextp);
5304
5305                 if (data) {
5306                     StructCopy(data, &data_fake, scan_data_t);
5307                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5308                         f |= SCF_DO_SUBSTR;
5309                         if (scan->flags)
5310                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5311                         data_fake.last_found=newSVsv(data->last_found);
5312                     }
5313                 }
5314                 else
5315                     data_fake.last_closep = &fake;
5316                 data_fake.flags = 0;
5317                 data_fake.pos_delta = delta;
5318                 if (is_inf)
5319                     data_fake.flags |= SF_IS_INF;
5320                 if ( flags & SCF_DO_STCLASS && !scan->flags
5321                      && OP(scan) == IFMATCH ) { /* Lookahead */
5322                     ssc_init(pRExC_state, &intrnl);
5323                     data_fake.start_class = &intrnl;
5324                     f |= SCF_DO_STCLASS_AND;
5325                 }
5326                 if (flags & SCF_WHILEM_VISITED_POS)
5327                     f |= SCF_WHILEM_VISITED_POS;
5328                 next = regnext(scan);
5329                 nscan = NEXTOPER(NEXTOPER(scan));
5330
5331                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5332                                         &deltanext, last, &data_fake,
5333                                         stopparen, recursed_depth, NULL,
5334                                         f,depth+1);
5335                 if (scan->flags) {
5336                     if (deltanext) {
5337                         FAIL("Variable length lookbehind not implemented");
5338                     }
5339                     else if (*minnextp > (I32)U8_MAX) {
5340                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5341                               (UV)U8_MAX);
5342                     }
5343                     scan->flags = (U8)*minnextp;
5344                 }
5345
5346                 *minnextp += min;
5347
5348                 if (f & SCF_DO_STCLASS_AND) {
5349                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5350                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5351                 }
5352                 if (data) {
5353                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5354                         pars++;
5355                     if (data_fake.flags & SF_HAS_EVAL)
5356                         data->flags |= SF_HAS_EVAL;
5357                     data->whilem_c = data_fake.whilem_c;
5358                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5359                         if (RExC_rx->minlen<*minnextp)
5360                             RExC_rx->minlen=*minnextp;
5361                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5362                         SvREFCNT_dec_NN(data_fake.last_found);
5363
5364                         if ( data_fake.minlen_fixed != minlenp )
5365                         {
5366                             data->offset_fixed= data_fake.offset_fixed;
5367                             data->minlen_fixed= data_fake.minlen_fixed;
5368                             data->lookbehind_fixed+= scan->flags;
5369                         }
5370                         if ( data_fake.minlen_float != minlenp )
5371                         {
5372                             data->minlen_float= data_fake.minlen_float;
5373                             data->offset_float_min=data_fake.offset_float_min;
5374                             data->offset_float_max=data_fake.offset_float_max;
5375                             data->lookbehind_float+= scan->flags;
5376                         }
5377                     }
5378                 }
5379             }
5380 #endif
5381         }
5382         else if (OP(scan) == OPEN) {
5383             if (stopparen != (I32)ARG(scan))
5384                 pars++;
5385         }
5386         else if (OP(scan) == CLOSE) {
5387             if (stopparen == (I32)ARG(scan)) {
5388                 break;
5389             }
5390             if ((I32)ARG(scan) == is_par) {
5391                 next = regnext(scan);
5392
5393                 if ( next && (OP(next) != WHILEM) && next < last)
5394                     is_par = 0;         /* Disable optimization */
5395             }
5396             if (data)
5397                 *(data->last_closep) = ARG(scan);
5398         }
5399         else if (OP(scan) == EVAL) {
5400                 if (data)
5401                     data->flags |= SF_HAS_EVAL;
5402         }
5403         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5404             if (flags & SCF_DO_SUBSTR) {
5405                 scan_commit(pRExC_state, data, minlenp, is_inf);
5406                 flags &= ~SCF_DO_SUBSTR;
5407             }
5408             if (data && OP(scan)==ACCEPT) {
5409                 data->flags |= SCF_SEEN_ACCEPT;
5410                 if (stopmin > min)
5411                     stopmin = min;
5412             }
5413         }
5414         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5415         {
5416                 if (flags & SCF_DO_SUBSTR) {
5417                     scan_commit(pRExC_state, data, minlenp, is_inf);
5418                     data->longest = &(data->longest_float);
5419                 }
5420                 is_inf = is_inf_internal = 1;
5421                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5422                     ssc_anything(data->start_class);
5423                 flags &= ~SCF_DO_STCLASS;
5424         }
5425         else if (OP(scan) == GPOS) {
5426             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5427                 !(delta || is_inf || (data && data->pos_delta)))
5428             {
5429                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5430                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5431                 if (RExC_rx->gofs < (STRLEN)min)
5432                     RExC_rx->gofs = min;
5433             } else {
5434                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5435                 RExC_rx->gofs = 0;
5436             }
5437         }
5438 #ifdef TRIE_STUDY_OPT
5439 #ifdef FULL_TRIE_STUDY
5440         else if (PL_regkind[OP(scan)] == TRIE) {
5441             /* NOTE - There is similar code to this block above for handling
5442                BRANCH nodes on the initial study.  If you change stuff here
5443                check there too. */
5444             regnode *trie_node= scan;
5445             regnode *tail= regnext(scan);
5446             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5447             SSize_t max1 = 0, min1 = SSize_t_MAX;
5448             regnode_ssc accum;
5449
5450             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5451                 /* Cannot merge strings after this. */
5452                 scan_commit(pRExC_state, data, minlenp, is_inf);
5453             }
5454             if (flags & SCF_DO_STCLASS)
5455                 ssc_init_zero(pRExC_state, &accum);
5456
5457             if (!trie->jump) {
5458                 min1= trie->minlen;
5459                 max1= trie->maxlen;
5460             } else {
5461                 const regnode *nextbranch= NULL;
5462                 U32 word;
5463
5464                 for ( word=1 ; word <= trie->wordcount ; word++)
5465                 {
5466                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5467                     regnode_ssc this_class;
5468
5469                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5470                     if (data) {
5471                         data_fake.whilem_c = data->whilem_c;
5472                         data_fake.last_closep = data->last_closep;
5473                     }
5474                     else
5475                         data_fake.last_closep = &fake;
5476                     data_fake.pos_delta = delta;
5477                     if (flags & SCF_DO_STCLASS) {
5478                         ssc_init(pRExC_state, &this_class);
5479                         data_fake.start_class = &this_class;
5480                         f = SCF_DO_STCLASS_AND;
5481                     }
5482                     if (flags & SCF_WHILEM_VISITED_POS)
5483                         f |= SCF_WHILEM_VISITED_POS;
5484
5485                     if (trie->jump[word]) {
5486                         if (!nextbranch)
5487                             nextbranch = trie_node + trie->jump[0];
5488                         scan= trie_node + trie->jump[word];
5489                         /* We go from the jump point to the branch that follows
5490                            it. Note this means we need the vestigal unused
5491                            branches even though they arent otherwise used. */
5492                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5493                             &deltanext, (regnode *)nextbranch, &data_fake,
5494                             stopparen, recursed_depth, NULL, f,depth+1);
5495                     }
5496                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5497                         nextbranch= regnext((regnode*)nextbranch);
5498
5499                     if (min1 > (SSize_t)(minnext + trie->minlen))
5500                         min1 = minnext + trie->minlen;
5501                     if (deltanext == SSize_t_MAX) {
5502                         is_inf = is_inf_internal = 1;
5503                         max1 = SSize_t_MAX;
5504                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5505                         max1 = minnext + deltanext + trie->maxlen;
5506
5507                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5508                         pars++;
5509                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5510                         if ( stopmin > min + min1)
5511                             stopmin = min + min1;
5512                         flags &= ~SCF_DO_SUBSTR;
5513                         if (data)
5514                             data->flags |= SCF_SEEN_ACCEPT;
5515                     }
5516                     if (data) {
5517                         if (data_fake.flags & SF_HAS_EVAL)
5518                             data->flags |= SF_HAS_EVAL;
5519                         data->whilem_c = data_fake.whilem_c;
5520                     }
5521                     if (flags & SCF_DO_STCLASS)
5522                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5523                 }
5524             }
5525             if (flags & SCF_DO_SUBSTR) {
5526                 data->pos_min += min1;
5527                 data->pos_delta += max1 - min1;
5528                 if (max1 != min1 || is_inf)
5529                     data->longest = &(data->longest_float);
5530             }
5531             min += min1;
5532             if (delta != SSize_t_MAX)
5533                 delta += max1 - min1;
5534             if (flags & SCF_DO_STCLASS_OR) {
5535                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5536                 if (min1) {
5537                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5538                     flags &= ~SCF_DO_STCLASS;
5539                 }
5540             }
5541             else if (flags & SCF_DO_STCLASS_AND) {
5542                 if (min1) {
5543                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5544                     flags &= ~SCF_DO_STCLASS;
5545                 }
5546                 else {
5547                     /* Switch to OR mode: cache the old value of
5548                      * data->start_class */
5549                     INIT_AND_WITHP;
5550                     StructCopy(data->start_class, and_withp, regnode_ssc);
5551                     flags &= ~SCF_DO_STCLASS_AND;
5552                     StructCopy(&accum, data->start_class, regnode_ssc);
5553                     flags |= SCF_DO_STCLASS_OR;
5554                 }
5555             }
5556             scan= tail;
5557             continue;
5558         }
5559 #else
5560         else if (PL_regkind[OP(scan)] == TRIE) {
5561             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5562             U8*bang=NULL;
5563
5564             min += trie->minlen;
5565             delta += (trie->maxlen - trie->minlen);
5566             flags &= ~SCF_DO_STCLASS; /* xxx */
5567             if (flags & SCF_DO_SUBSTR) {
5568                 /* Cannot expect anything... */
5569                 scan_commit(pRExC_state, data, minlenp, is_inf);
5570                 data->pos_min += trie->minlen;
5571                 data->pos_delta += (trie->maxlen - trie->minlen);
5572                 if (trie->maxlen != trie->minlen)
5573                     data->longest = &(data->longest_float);
5574             }
5575             if (trie->jump) /* no more substrings -- for now /grr*/
5576                flags &= ~SCF_DO_SUBSTR;
5577         }
5578 #endif /* old or new */
5579 #endif /* TRIE_STUDY_OPT */
5580
5581         /* Else: zero-length, ignore. */
5582         scan = regnext(scan);
5583     }
5584     /* If we are exiting a recursion we can unset its recursed bit
5585      * and allow ourselves to enter it again - no danger of an
5586      * infinite loop there.
5587     if (stopparen > -1 && recursed) {
5588         DEBUG_STUDYDATA("unset:", data,depth);
5589         PAREN_UNSET( recursed, stopparen);
5590     }
5591     */
5592     if (frame) {
5593         depth = depth - 1;
5594
5595         DEBUG_STUDYDATA("frame-end:",data,depth);
5596         DEBUG_PEEP("fend", scan, depth);
5597
5598         /* restore previous context */
5599         last = frame->last_regnode;
5600         scan = frame->next_regnode;
5601         stopparen = frame->stopparen;
5602         recursed_depth = frame->prev_recursed_depth;
5603
5604         RExC_frame_last = frame->prev_frame;
5605         frame = frame->this_prev_frame;
5606         goto fake_study_recurse;
5607     }
5608
5609   finish:
5610     assert(!frame);
5611     DEBUG_STUDYDATA("pre-fin:",data,depth);
5612
5613     *scanp = scan;
5614     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5615
5616     if (flags & SCF_DO_SUBSTR && is_inf)
5617         data->pos_delta = SSize_t_MAX - data->pos_min;
5618     if (is_par > (I32)U8_MAX)
5619         is_par = 0;
5620     if (is_par && pars==1 && data) {
5621         data->flags |= SF_IN_PAR;
5622         data->flags &= ~SF_HAS_PAR;
5623     }
5624     else if (pars && data) {
5625         data->flags |= SF_HAS_PAR;
5626         data->flags &= ~SF_IN_PAR;
5627     }
5628     if (flags & SCF_DO_STCLASS_OR)
5629         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5630     if (flags & SCF_TRIE_RESTUDY)
5631         data->flags |=  SCF_TRIE_RESTUDY;
5632
5633     DEBUG_STUDYDATA("post-fin:",data,depth);
5634
5635     {
5636         SSize_t final_minlen= min < stopmin ? min : stopmin;
5637
5638         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
5639             if (final_minlen > SSize_t_MAX - delta)
5640                 RExC_maxlen = SSize_t_MAX;
5641             else if (RExC_maxlen < final_minlen + delta)
5642                 RExC_maxlen = final_minlen + delta;
5643         }
5644         return final_minlen;
5645     }
5646     NOT_REACHED; /* NOTREACHED */
5647 }
5648
5649 STATIC U32
5650 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5651 {
5652     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5653
5654     PERL_ARGS_ASSERT_ADD_DATA;
5655
5656     Renewc(RExC_rxi->data,
5657            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
5658            char, struct reg_data);
5659     if(count)
5660         Renew(RExC_rxi->data->what, count + n, U8);
5661     else
5662         Newx(RExC_rxi->data->what, n, U8);
5663     RExC_rxi->data->count = count + n;
5664     Copy(s, RExC_rxi->data->what + count, n, U8);
5665     return count;
5666 }
5667
5668 /*XXX: todo make this not included in a non debugging perl, but appears to be
5669  * used anyway there, in 'use re' */
5670 #ifndef PERL_IN_XSUB_RE
5671 void
5672 Perl_reginitcolors(pTHX)
5673 {
5674     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
5675     if (s) {
5676         char *t = savepv(s);
5677         int i = 0;
5678         PL_colors[0] = t;
5679         while (++i < 6) {
5680             t = strchr(t, '\t');
5681             if (t) {
5682                 *t = '\0';
5683                 PL_colors[i] = ++t;
5684             }
5685             else
5686                 PL_colors[i] = t = (char *)"";
5687         }
5688     } else {
5689         int i = 0;
5690         while (i < 6)
5691             PL_colors[i++] = (char *)"";
5692     }
5693     PL_colorset = 1;
5694 }
5695 #endif
5696
5697
5698 #ifdef TRIE_STUDY_OPT
5699 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
5700     STMT_START {                                            \
5701         if (                                                \
5702               (data.flags & SCF_TRIE_RESTUDY)               \
5703               && ! restudied++                              \
5704         ) {                                                 \
5705             dOsomething;                                    \
5706             goto reStudy;                                   \
5707         }                                                   \
5708     } STMT_END
5709 #else
5710 #define CHECK_RESTUDY_GOTO_butfirst
5711 #endif
5712
5713 /*
5714  * pregcomp - compile a regular expression into internal code
5715  *
5716  * Decides which engine's compiler to call based on the hint currently in
5717  * scope
5718  */
5719
5720 #ifndef PERL_IN_XSUB_RE
5721
5722 /* return the currently in-scope regex engine (or the default if none)  */
5723
5724 regexp_engine const *
5725 Perl_current_re_engine(pTHX)
5726 {
5727     if (IN_PERL_COMPILETIME) {
5728         HV * const table = GvHV(PL_hintgv);
5729         SV **ptr;
5730
5731         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
5732             return &PL_core_reg_engine;
5733         ptr = hv_fetchs(table, "regcomp", FALSE);
5734         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
5735             return &PL_core_reg_engine;
5736         return INT2PTR(regexp_engine*,SvIV(*ptr));
5737     }
5738     else {
5739         SV *ptr;
5740         if (!PL_curcop->cop_hints_hash)
5741             return &PL_core_reg_engine;
5742         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
5743         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
5744             return &PL_core_reg_engine;
5745         return INT2PTR(regexp_engine*,SvIV(ptr));
5746     }
5747 }
5748
5749
5750 REGEXP *
5751 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
5752 {
5753     regexp_engine const *eng = current_re_engine();
5754     GET_RE_DEBUG_FLAGS_DECL;
5755
5756     PERL_ARGS_ASSERT_PREGCOMP;
5757
5758     /* Dispatch a request to compile a regexp to correct regexp engine. */
5759     DEBUG_COMPILE_r({
5760         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
5761                         PTR2UV(eng));
5762     });
5763     return CALLREGCOMP_ENG(eng, pattern, flags);
5764 }
5765 #endif
5766
5767 /* public(ish) entry point for the perl core's own regex compiling code.
5768  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
5769  * pattern rather than a list of OPs, and uses the internal engine rather
5770  * than the current one */
5771
5772 REGEXP *
5773 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
5774 {
5775     SV *pat = pattern; /* defeat constness! */
5776     PERL_ARGS_ASSERT_RE_COMPILE;
5777     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
5778 #ifdef PERL_IN_XSUB_RE
5779                                 &my_reg_engine,
5780 #else
5781                                 &PL_core_reg_engine,
5782 #endif
5783                                 NULL, NULL, rx_flags, 0);
5784 }
5785
5786
5787 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
5788  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
5789  * point to the realloced string and length.
5790  *
5791  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
5792  * stuff added */
5793
5794 static void
5795 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
5796                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
5797 {
5798     U8 *const src = (U8*)*pat_p;
5799     U8 *dst, *d;
5800     int n=0;
5801     STRLEN s = 0;
5802     bool do_end = 0;
5803     GET_RE_DEBUG_FLAGS_DECL;
5804
5805     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5806         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5807
5808     Newx(dst, *plen_p * 2 + 1, U8);
5809     d = dst;
5810
5811     while (s < *plen_p) {
5812         append_utf8_from_native_byte(src[s], &d);
5813         if (n < num_code_blocks) {
5814             if (!do_end && pRExC_state->code_blocks[n].start == s) {
5815                 pRExC_state->code_blocks[n].start = d - dst - 1;
5816                 assert(*(d - 1) == '(');
5817                 do_end = 1;
5818             }
5819             else if (do_end && pRExC_state->code_blocks[n].end == s) {
5820                 pRExC_state->code_blocks[n].end = d - dst - 1;
5821                 assert(*(d - 1) == ')');
5822                 do_end = 0;
5823                 n++;
5824             }
5825         }
5826         s++;
5827     }
5828     *d = '\0';
5829     *plen_p = d - dst;
5830     *pat_p = (char*) dst;
5831     SAVEFREEPV(*pat_p);
5832     RExC_orig_utf8 = RExC_utf8 = 1;
5833 }
5834
5835
5836
5837 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
5838  * while recording any code block indices, and handling overloading,
5839  * nested qr// objects etc.  If pat is null, it will allocate a new
5840  * string, or just return the first arg, if there's only one.
5841  *
5842  * Returns the malloced/updated pat.
5843  * patternp and pat_count is the array of SVs to be concatted;
5844  * oplist is the optional list of ops that generated the SVs;
5845  * recompile_p is a pointer to a boolean that will be set if
5846  *   the regex will need to be recompiled.
5847  * delim, if non-null is an SV that will be inserted between each element
5848  */
5849
5850 static SV*
5851 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
5852                 SV *pat, SV ** const patternp, int pat_count,
5853                 OP *oplist, bool *recompile_p, SV *delim)
5854 {
5855     SV **svp;
5856     int n = 0;
5857     bool use_delim = FALSE;
5858     bool alloced = FALSE;
5859
5860     /* if we know we have at least two args, create an empty string,
5861      * then concatenate args to that. For no args, return an empty string */
5862     if (!pat && pat_count != 1) {
5863         pat = newSVpvs("");
5864         SAVEFREESV(pat);
5865         alloced = TRUE;
5866     }
5867
5868     for (svp = patternp; svp < patternp + pat_count; svp++) {
5869         SV *sv;
5870         SV *rx  = NULL;
5871         STRLEN orig_patlen = 0;
5872         bool code = 0;
5873         SV *msv = use_delim ? delim : *svp;
5874         if (!msv) msv = &PL_sv_undef;
5875
5876         /* if we've got a delimiter, we go round the loop twice for each
5877          * svp slot (except the last), using the delimiter the second
5878          * time round */
5879         if (use_delim) {
5880             svp--;
5881             use_delim = FALSE;
5882         }
5883         else if (delim)
5884             use_delim = TRUE;
5885
5886         if (SvTYPE(msv) == SVt_PVAV) {
5887             /* we've encountered an interpolated array within
5888              * the pattern, e.g. /...@a..../. Expand the list of elements,
5889              * then recursively append elements.
5890              * The code in this block is based on S_pushav() */
5891
5892             AV *const av = (AV*)msv;
5893             const SSize_t maxarg = AvFILL(av) + 1;
5894             SV **array;
5895
5896             if (oplist) {
5897                 assert(oplist->op_type == OP_PADAV
5898                     || oplist->op_type == OP_RV2AV);
5899                 oplist = OpSIBLING(oplist);
5900             }
5901
5902             if (SvRMAGICAL(av)) {
5903                 SSize_t i;
5904
5905                 Newx(array, maxarg, SV*);
5906                 SAVEFREEPV(array);
5907                 for (i=0; i < maxarg; i++) {
5908                     SV ** const svp = av_fetch(av, i, FALSE);
5909                     array[i] = svp ? *svp : &PL_sv_undef;
5910                 }
5911             }
5912             else
5913                 array = AvARRAY(av);
5914
5915             pat = S_concat_pat(aTHX_ pRExC_state, pat,
5916                                 array, maxarg, NULL, recompile_p,
5917                                 /* $" */
5918                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
5919
5920             continue;
5921         }
5922
5923
5924         /* we make the assumption here that each op in the list of
5925          * op_siblings maps to one SV pushed onto the stack,
5926          * except for code blocks, with have both an OP_NULL and
5927          * and OP_CONST.
5928          * This allows us to match up the list of SVs against the
5929          * list of OPs to find the next code block.
5930          *
5931          * Note that       PUSHMARK PADSV PADSV ..
5932          * is optimised to
5933          *                 PADRANGE PADSV  PADSV  ..
5934          * so the alignment still works. */
5935
5936         if (oplist) {
5937             if (oplist->op_type == OP_NULL
5938                 && (oplist->op_flags & OPf_SPECIAL))
5939             {
5940                 assert(n < pRExC_state->num_code_blocks);
5941                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
5942                 pRExC_state->code_blocks[n].block = oplist;
5943                 pRExC_state->code_blocks[n].src_regex = NULL;
5944                 n++;
5945                 code = 1;
5946                 oplist = OpSIBLING(oplist); /* skip CONST */
5947                 assert(oplist);
5948             }
5949             oplist = OpSIBLING(oplist);;
5950         }
5951
5952         /* apply magic and QR overloading to arg */
5953
5954         SvGETMAGIC(msv);
5955         if (SvROK(msv) && SvAMAGIC(msv)) {
5956             SV *sv = AMG_CALLunary(msv, regexp_amg);
5957             if (sv) {
5958                 if (SvROK(sv))
5959                     sv = SvRV(sv);
5960                 if (SvTYPE(sv) != SVt_REGEXP)
5961                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5962                 msv = sv;
5963             }
5964         }
5965
5966         /* try concatenation overload ... */
5967         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5968                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5969         {
5970             sv_setsv(pat, sv);
5971             /* overloading involved: all bets are off over literal
5972              * code. Pretend we haven't seen it */
5973             pRExC_state->num_code_blocks -= n;
5974             n = 0;
5975         }
5976         else  {
5977             /* ... or failing that, try "" overload */
5978             while (SvAMAGIC(msv)
5979                     && (sv = AMG_CALLunary(msv, string_amg))
5980                     && sv != msv
5981                     &&  !(   SvROK(msv)
5982                           && SvROK(sv)
5983                           && SvRV(msv) == SvRV(sv))
5984             ) {
5985                 msv = sv;
5986                 SvGETMAGIC(msv);
5987             }
5988             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5989                 msv = SvRV(msv);
5990
5991             if (pat) {
5992                 /* this is a partially unrolled
5993                  *     sv_catsv_nomg(pat, msv);
5994                  * that allows us to adjust code block indices if
5995                  * needed */
5996                 STRLEN dlen;
5997                 char *dst = SvPV_force_nomg(pat, dlen);
5998                 orig_patlen = dlen;
5999                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6000                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6001                     sv_setpvn(pat, dst, dlen);
6002                     SvUTF8_on(pat);
6003                 }
6004                 sv_catsv_nomg(pat, msv);
6005                 rx = msv;
6006             }
6007             else
6008                 pat = msv;
6009
6010             if (code)
6011                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
6012         }
6013
6014         /* extract any code blocks within any embedded qr//'s */
6015         if (rx && SvTYPE(rx) == SVt_REGEXP
6016             && RX_ENGINE((REGEXP*)rx)->op_comp)
6017         {
6018
6019             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6020             if (ri->num_code_blocks) {
6021                 int i;
6022                 /* the presence of an embedded qr// with code means
6023                  * we should always recompile: the text of the
6024                  * qr// may not have changed, but it may be a
6025                  * different closure than last time */
6026                 *recompile_p = 1;
6027                 Renew(pRExC_state->code_blocks,
6028                     pRExC_state->num_code_blocks + ri->num_code_blocks,
6029                     struct reg_code_block);
6030                 pRExC_state->num_code_blocks += ri->num_code_blocks;
6031
6032                 for (i=0; i < ri->num_code_blocks; i++) {
6033                     struct reg_code_block *src, *dst;
6034                     STRLEN offset =  orig_patlen
6035                         + ReANY((REGEXP *)rx)->pre_prefix;
6036                     assert(n < pRExC_state->num_code_blocks);
6037                     src = &ri->code_blocks[i];
6038                     dst = &pRExC_state->code_blocks[n];
6039                     dst->start      = src->start + offset;
6040                     dst->end        = src->end   + offset;
6041                     dst->block      = src->block;
6042                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6043                                             src->src_regex
6044                                                 ? src->src_regex
6045                                                 : (REGEXP*)rx);
6046                     n++;
6047                 }
6048             }
6049         }
6050     }
6051     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6052     if (alloced)
6053         SvSETMAGIC(pat);
6054
6055     return pat;
6056 }
6057
6058
6059
6060 /* see if there are any run-time code blocks in the pattern.
6061  * False positives are allowed */
6062
6063 static bool
6064 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6065                     char *pat, STRLEN plen)
6066 {
6067     int n = 0;
6068     STRLEN s;
6069     
6070     PERL_UNUSED_CONTEXT;
6071
6072     for (s = 0; s < plen; s++) {
6073         if (n < pRExC_state->num_code_blocks
6074             && s == pRExC_state->code_blocks[n].start)
6075         {
6076             s = pRExC_state->code_blocks[n].end;
6077             n++;
6078             continue;
6079         }
6080         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6081          * positives here */
6082         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6083             (pat[s+2] == '{'
6084                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6085         )
6086             return 1;
6087     }
6088     return 0;
6089 }
6090
6091 /* Handle run-time code blocks. We will already have compiled any direct
6092  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6093  * copy of it, but with any literal code blocks blanked out and
6094  * appropriate chars escaped; then feed it into
6095  *
6096  *    eval "qr'modified_pattern'"
6097  *
6098  * For example,
6099  *
6100  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6101  *
6102  * becomes
6103  *
6104  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6105  *
6106  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6107  * and merge them with any code blocks of the original regexp.
6108  *
6109  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6110  * instead, just save the qr and return FALSE; this tells our caller that
6111  * the original pattern needs upgrading to utf8.
6112  */
6113
6114 static bool
6115 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6116     char *pat, STRLEN plen)
6117 {
6118     SV *qr;
6119
6120     GET_RE_DEBUG_FLAGS_DECL;
6121
6122     if (pRExC_state->runtime_code_qr) {
6123         /* this is the second time we've been called; this should
6124          * only happen if the main pattern got upgraded to utf8
6125          * during compilation; re-use the qr we compiled first time
6126          * round (which should be utf8 too)
6127          */
6128         qr = pRExC_state->runtime_code_qr;
6129         pRExC_state->runtime_code_qr = NULL;
6130         assert(RExC_utf8 && SvUTF8(qr));
6131     }
6132     else {
6133         int n = 0;
6134         STRLEN s;
6135         char *p, *newpat;
6136         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
6137         SV *sv, *qr_ref;
6138         dSP;
6139
6140         /* determine how many extra chars we need for ' and \ escaping */
6141         for (s = 0; s < plen; s++) {
6142             if (pat[s] == '\'' || pat[s] == '\\')
6143                 newlen++;
6144         }
6145
6146         Newx(newpat, newlen, char);
6147         p = newpat;
6148         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6149
6150         for (s = 0; s < plen; s++) {
6151             if (n < pRExC_state->num_code_blocks
6152                 && s == pRExC_state->code_blocks[n].start)
6153             {
6154                 /* blank out literal code block */
6155                 assert(pat[s] == '(');
6156                 while (s <= pRExC_state->code_blocks[n].end) {
6157                     *p++ = '_';
6158                     s++;
6159                 }
6160                 s--;
6161                 n++;
6162                 continue;
6163             }
6164             if (pat[s] == '\'' || pat[s] == '\\')
6165                 *p++ = '\\';
6166             *p++ = pat[s];
6167         }
6168         *p++ = '\'';
6169         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
6170             *p++ = 'x';
6171         *p++ = '\0';
6172         DEBUG_COMPILE_r({
6173             PerlIO_printf(Perl_debug_log,
6174                 "%sre-parsing pattern for runtime code:%s %s\n",
6175                 PL_colors[4],PL_colors[5],newpat);
6176         });
6177
6178         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6179         Safefree(newpat);
6180
6181         ENTER;
6182         SAVETMPS;
6183         save_re_context();
6184         PUSHSTACKi(PERLSI_REQUIRE);
6185         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6186          * parsing qr''; normally only q'' does this. It also alters
6187          * hints handling */
6188         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6189         SvREFCNT_dec_NN(sv);
6190         SPAGAIN;
6191         qr_ref = POPs;
6192         PUTBACK;
6193         {
6194             SV * const errsv = ERRSV;
6195             if (SvTRUE_NN(errsv))
6196             {
6197                 Safefree(pRExC_state->code_blocks);
6198                 /* use croak_sv ? */
6199                 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
6200             }
6201         }
6202         assert(SvROK(qr_ref));
6203         qr = SvRV(qr_ref);
6204         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6205         /* the leaving below frees the tmp qr_ref.
6206          * Give qr a life of its own */
6207         SvREFCNT_inc(qr);
6208         POPSTACK;
6209         FREETMPS;
6210         LEAVE;
6211
6212     }
6213
6214     if (!RExC_utf8 && SvUTF8(qr)) {
6215         /* first time through; the pattern got upgraded; save the
6216          * qr for the next time through */
6217         assert(!pRExC_state->runtime_code_qr);
6218         pRExC_state->runtime_code_qr = qr;
6219         return 0;
6220     }
6221
6222
6223     /* extract any code blocks within the returned qr//  */
6224
6225
6226     /* merge the main (r1) and run-time (r2) code blocks into one */
6227     {
6228         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6229         struct reg_code_block *new_block, *dst;
6230         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6231         int i1 = 0, i2 = 0;
6232
6233         if (!r2->num_code_blocks) /* we guessed wrong */
6234         {
6235             SvREFCNT_dec_NN(qr);
6236             return 1;
6237         }
6238
6239         Newx(new_block,
6240             r1->num_code_blocks + r2->num_code_blocks,
6241             struct reg_code_block);
6242         dst = new_block;
6243
6244         while (    i1 < r1->num_code_blocks
6245                 || i2 < r2->num_code_blocks)
6246         {
6247             struct reg_code_block *src;
6248             bool is_qr = 0;
6249
6250             if (i1 == r1->num_code_blocks) {
6251                 src = &r2->code_blocks[i2++];
6252                 is_qr = 1;
6253             }
6254             else if (i2 == r2->num_code_blocks)
6255                 src = &r1->code_blocks[i1++];
6256             else if (  r1->code_blocks[i1].start
6257                      < r2->code_blocks[i2].start)
6258             {
6259                 src = &r1->code_blocks[i1++];
6260                 assert(src->end < r2->code_blocks[i2].start);
6261             }
6262             else {
6263                 assert(  r1->code_blocks[i1].start
6264                        > r2->code_blocks[i2].start);
6265                 src = &r2->code_blocks[i2++];
6266                 is_qr = 1;
6267                 assert(src->end < r1->code_blocks[i1].start);
6268             }
6269
6270             assert(pat[src->start] == '(');
6271             assert(pat[src->end]   == ')');
6272             dst->start      = src->start;
6273             dst->end        = src->end;
6274             dst->block      = src->block;
6275             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6276                                     : src->src_regex;
6277             dst++;
6278         }
6279         r1->num_code_blocks += r2->num_code_blocks;
6280         Safefree(r1->code_blocks);
6281         r1->code_blocks = new_block;
6282     }
6283
6284     SvREFCNT_dec_NN(qr);
6285     return 1;
6286 }
6287
6288
6289 STATIC bool
6290 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6291                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6292                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6293                       STRLEN longest_length, bool eol, bool meol)
6294 {
6295     /* This is the common code for setting up the floating and fixed length
6296      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6297      * as to whether succeeded or not */
6298
6299     I32 t;
6300     SSize_t ml;
6301
6302     if (! (longest_length
6303            || (eol /* Can't have SEOL and MULTI */
6304                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6305           )
6306             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6307         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6308     {
6309         return FALSE;
6310     }
6311
6312     /* copy the information about the longest from the reg_scan_data
6313         over to the program. */
6314     if (SvUTF8(sv_longest)) {
6315         *rx_utf8 = sv_longest;
6316         *rx_substr = NULL;
6317     } else {
6318         *rx_substr = sv_longest;
6319         *rx_utf8 = NULL;
6320     }
6321     /* end_shift is how many chars that must be matched that
6322         follow this item. We calculate it ahead of time as once the
6323         lookbehind offset is added in we lose the ability to correctly
6324         calculate it.*/
6325     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6326     *rx_end_shift = ml - offset
6327         - longest_length + (SvTAIL(sv_longest) != 0)
6328         + lookbehind;
6329
6330     t = (eol/* Can't have SEOL and MULTI */
6331          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6332     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6333
6334     return TRUE;
6335 }
6336
6337 /*
6338  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6339  * regular expression into internal code.
6340  * The pattern may be passed either as:
6341  *    a list of SVs (patternp plus pat_count)
6342  *    a list of OPs (expr)
6343  * If both are passed, the SV list is used, but the OP list indicates
6344  * which SVs are actually pre-compiled code blocks
6345  *
6346  * The SVs in the list have magic and qr overloading applied to them (and
6347  * the list may be modified in-place with replacement SVs in the latter
6348  * case).
6349  *
6350  * If the pattern hasn't changed from old_re, then old_re will be
6351  * returned.
6352  *
6353  * eng is the current engine. If that engine has an op_comp method, then
6354  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6355  * do the initial concatenation of arguments and pass on to the external
6356  * engine.
6357  *
6358  * If is_bare_re is not null, set it to a boolean indicating whether the
6359  * arg list reduced (after overloading) to a single bare regex which has
6360  * been returned (i.e. /$qr/).
6361  *
6362  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6363  *
6364  * pm_flags contains the PMf_* flags, typically based on those from the
6365  * pm_flags field of the related PMOP. Currently we're only interested in
6366  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6367  *
6368  * We can't allocate space until we know how big the compiled form will be,
6369  * but we can't compile it (and thus know how big it is) until we've got a
6370  * place to put the code.  So we cheat:  we compile it twice, once with code
6371  * generation turned off and size counting turned on, and once "for real".
6372  * This also means that we don't allocate space until we are sure that the
6373  * thing really will compile successfully, and we never have to move the
6374  * code and thus invalidate pointers into it.  (Note that it has to be in
6375  * one piece because free() must be able to free it all.) [NB: not true in perl]
6376  *
6377  * Beware that the optimization-preparation code in here knows about some
6378  * of the structure of the compiled regexp.  [I'll say.]
6379  */
6380
6381 REGEXP *
6382 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6383                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6384                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6385 {
6386     REGEXP *rx;
6387     struct regexp *r;
6388     regexp_internal *ri;
6389     STRLEN plen;
6390     char *exp;
6391     regnode *scan;
6392     I32 flags;
6393     SSize_t minlen = 0;
6394     U32 rx_flags;
6395     SV *pat;
6396     SV *code_blocksv = NULL;
6397     SV** new_patternp = patternp;
6398
6399     /* these are all flags - maybe they should be turned
6400      * into a single int with different bit masks */
6401     I32 sawlookahead = 0;
6402     I32 sawplus = 0;
6403     I32 sawopen = 0;
6404     I32 sawminmod = 0;
6405
6406     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6407     bool recompile = 0;
6408     bool runtime_code = 0;
6409     scan_data_t data;
6410     RExC_state_t RExC_state;
6411     RExC_state_t * const pRExC_state = &RExC_state;
6412 #ifdef TRIE_STUDY_OPT
6413     int restudied = 0;
6414     RExC_state_t copyRExC_state;
6415 #endif
6416     GET_RE_DEBUG_FLAGS_DECL;
6417
6418     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6419
6420     DEBUG_r(if (!PL_colorset) reginitcolors());
6421
6422     /* Initialize these here instead of as-needed, as is quick and avoids
6423      * having to test them each time otherwise */
6424     if (! PL_AboveLatin1) {
6425         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6426         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6427         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6428         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6429         PL_HasMultiCharFold =
6430                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6431
6432         /* This is calculated here, because the Perl program that generates the
6433          * static global ones doesn't currently have access to
6434          * NUM_ANYOF_CODE_POINTS */
6435         PL_InBitmap = _new_invlist(2);
6436         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6437                                                     NUM_ANYOF_CODE_POINTS - 1);
6438     }
6439
6440     pRExC_state->code_blocks = NULL;
6441     pRExC_state->num_code_blocks = 0;
6442
6443     if (is_bare_re)
6444         *is_bare_re = FALSE;
6445
6446     if (expr && (expr->op_type == OP_LIST ||
6447                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6448         /* allocate code_blocks if needed */
6449         OP *o;
6450         int ncode = 0;
6451
6452         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6453             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6454                 ncode++; /* count of DO blocks */
6455         if (ncode) {
6456             pRExC_state->num_code_blocks = ncode;
6457             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
6458         }
6459     }
6460
6461     if (!pat_count) {
6462         /* compile-time pattern with just OP_CONSTs and DO blocks */
6463
6464         int n;
6465         OP *o;
6466
6467         /* find how many CONSTs there are */
6468         assert(expr);
6469         n = 0;
6470         if (expr->op_type == OP_CONST)
6471             n = 1;
6472         else
6473             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6474                 if (o->op_type == OP_CONST)
6475                     n++;
6476             }
6477
6478         /* fake up an SV array */
6479
6480         assert(!new_patternp);
6481         Newx(new_patternp, n, SV*);
6482         SAVEFREEPV(new_patternp);
6483         pat_count = n;
6484
6485         n = 0;
6486         if (expr->op_type == OP_CONST)
6487             new_patternp[n] = cSVOPx_sv(expr);
6488         else
6489             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6490                 if (o->op_type == OP_CONST)
6491                     new_patternp[n++] = cSVOPo_sv;
6492             }
6493
6494     }
6495
6496     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6497         "Assembling pattern from %d elements%s\n", pat_count,
6498             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6499
6500     /* set expr to the first arg op */
6501
6502     if (pRExC_state->num_code_blocks
6503          && expr->op_type != OP_CONST)
6504     {
6505             expr = cLISTOPx(expr)->op_first;
6506             assert(   expr->op_type == OP_PUSHMARK
6507                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6508                    || expr->op_type == OP_PADRANGE);
6509             expr = OpSIBLING(expr);
6510     }
6511
6512     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6513                         expr, &recompile, NULL);
6514
6515     /* handle bare (possibly after overloading) regex: foo =~ $re */
6516     {
6517         SV *re = pat;
6518         if (SvROK(re))
6519             re = SvRV(re);
6520         if (SvTYPE(re) == SVt_REGEXP) {
6521             if (is_bare_re)
6522                 *is_bare_re = TRUE;
6523             SvREFCNT_inc(re);
6524             Safefree(pRExC_state->code_blocks);
6525             DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6526                 "Precompiled pattern%s\n",
6527                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6528
6529             return (REGEXP*)re;
6530         }
6531     }
6532
6533     exp = SvPV_nomg(pat, plen);
6534
6535     if (!eng->op_comp) {
6536         if ((SvUTF8(pat) && IN_BYTES)
6537                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6538         {
6539             /* make a temporary copy; either to convert to bytes,
6540              * or to avoid repeating get-magic / overloaded stringify */
6541             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6542                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6543         }
6544         Safefree(pRExC_state->code_blocks);
6545         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6546     }
6547
6548     /* ignore the utf8ness if the pattern is 0 length */
6549     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6550     RExC_uni_semantics = 0;
6551     RExC_contains_locale = 0;
6552     RExC_contains_i = 0;
6553     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
6554     pRExC_state->runtime_code_qr = NULL;
6555     RExC_frame_head= NULL;
6556     RExC_frame_last= NULL;
6557     RExC_frame_count= 0;
6558
6559     DEBUG_r({
6560         RExC_mysv1= sv_newmortal();
6561         RExC_mysv2= sv_newmortal();
6562     });
6563     DEBUG_COMPILE_r({
6564             SV *dsv= sv_newmortal();
6565             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6566             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
6567                           PL_colors[4],PL_colors[5],s);
6568         });
6569
6570   redo_first_pass:
6571     /* we jump here if we upgrade the pattern to utf8 and have to
6572      * recompile */
6573
6574     if ((pm_flags & PMf_USE_RE_EVAL)
6575                 /* this second condition covers the non-regex literal case,
6576                  * i.e.  $foo =~ '(?{})'. */
6577                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6578     )
6579         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6580
6581     /* return old regex if pattern hasn't changed */
6582     /* XXX: note in the below we have to check the flags as well as the
6583      * pattern.
6584      *
6585      * Things get a touch tricky as we have to compare the utf8 flag
6586      * independently from the compile flags.  */
6587
6588     if (   old_re
6589         && !recompile
6590         && !!RX_UTF8(old_re) == !!RExC_utf8
6591         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
6592         && RX_PRECOMP(old_re)
6593         && RX_PRELEN(old_re) == plen
6594         && memEQ(RX_PRECOMP(old_re), exp, plen)
6595         && !runtime_code /* with runtime code, always recompile */ )
6596     {
6597         Safefree(pRExC_state->code_blocks);
6598         return old_re;
6599     }
6600
6601     rx_flags = orig_rx_flags;
6602
6603     if (rx_flags & PMf_FOLD) {
6604         RExC_contains_i = 1;
6605     }
6606     if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
6607
6608         /* Set to use unicode semantics if the pattern is in utf8 and has the
6609          * 'depends' charset specified, as it means unicode when utf8  */
6610         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6611     }
6612
6613     RExC_precomp = exp;
6614     RExC_flags = rx_flags;
6615     RExC_pm_flags = pm_flags;
6616
6617     if (runtime_code) {
6618         if (TAINTING_get && TAINT_get)
6619             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
6620
6621         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
6622             /* whoops, we have a non-utf8 pattern, whilst run-time code
6623              * got compiled as utf8. Try again with a utf8 pattern */
6624             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6625                                     pRExC_state->num_code_blocks);
6626             goto redo_first_pass;
6627         }
6628     }
6629     assert(!pRExC_state->runtime_code_qr);
6630
6631     RExC_sawback = 0;
6632
6633     RExC_seen = 0;
6634     RExC_maxlen = 0;
6635     RExC_in_lookbehind = 0;
6636     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
6637     RExC_extralen = 0;
6638     RExC_override_recoding = 0;
6639 #ifdef EBCDIC
6640     RExC_recode_x_to_native = 0;
6641 #endif
6642     RExC_in_multi_char_class = 0;
6643
6644     /* First pass: determine size, legality. */
6645     RExC_parse = exp;
6646     RExC_start = exp;
6647     RExC_end = exp + plen;
6648     RExC_naughty = 0;
6649     RExC_npar = 1;
6650     RExC_nestroot = 0;
6651     RExC_size = 0L;
6652     RExC_emit = (regnode *) &RExC_emit_dummy;
6653     RExC_whilem_seen = 0;
6654     RExC_open_parens = NULL;
6655     RExC_close_parens = NULL;
6656     RExC_opend = NULL;
6657     RExC_paren_names = NULL;
6658 #ifdef DEBUGGING
6659     RExC_paren_name_list = NULL;
6660 #endif
6661     RExC_recurse = NULL;
6662     RExC_study_chunk_recursed = NULL;
6663     RExC_study_chunk_recursed_bytes= 0;
6664     RExC_recurse_count = 0;
6665     pRExC_state->code_index = 0;
6666
6667     DEBUG_PARSE_r(
6668         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
6669         RExC_lastnum=0;
6670         RExC_lastparse=NULL;
6671     );
6672     /* reg may croak on us, not giving us a chance to free
6673        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
6674        need it to survive as long as the regexp (qr/(?{})/).
6675        We must check that code_blocksv is not already set, because we may
6676        have jumped back to restart the sizing pass. */
6677     if (pRExC_state->code_blocks && !code_blocksv) {
6678         code_blocksv = newSV_type(SVt_PV);
6679         SAVEFREESV(code_blocksv);
6680         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
6681         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
6682     }
6683     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6684         /* It's possible to write a regexp in ascii that represents Unicode
6685         codepoints outside of the byte range, such as via \x{100}. If we
6686         detect such a sequence we have to convert the entire pattern to utf8
6687         and then recompile, as our sizing calculation will have been based
6688         on 1 byte == 1 character, but we will need to use utf8 to encode
6689         at least some part of the pattern, and therefore must convert the whole
6690         thing.
6691         -- dmq */
6692         if (flags & RESTART_UTF8) {
6693             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6694                                     pRExC_state->num_code_blocks);
6695             goto redo_first_pass;
6696         }
6697         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#"UVxf"", (UV) flags);
6698     }
6699     if (code_blocksv)
6700         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
6701
6702     DEBUG_PARSE_r({
6703         PerlIO_printf(Perl_debug_log,
6704             "Required size %"IVdf" nodes\n"
6705             "Starting second pass (creation)\n",
6706             (IV)RExC_size);
6707         RExC_lastnum=0;
6708         RExC_lastparse=NULL;
6709     });
6710
6711     /* The first pass could have found things that force Unicode semantics */
6712     if ((RExC_utf8 || RExC_uni_semantics)
6713          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
6714     {
6715         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6716     }
6717
6718     /* Small enough for pointer-storage convention?
6719        If extralen==0, this means that we will not need long jumps. */
6720     if (RExC_size >= 0x10000L && RExC_extralen)
6721         RExC_size += RExC_extralen;
6722     else
6723         RExC_extralen = 0;
6724     if (RExC_whilem_seen > 15)
6725         RExC_whilem_seen = 15;
6726
6727     /* Allocate space and zero-initialize. Note, the two step process
6728        of zeroing when in debug mode, thus anything assigned has to
6729        happen after that */
6730     rx = (REGEXP*) newSV_type(SVt_REGEXP);
6731     r = ReANY(rx);
6732     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
6733          char, regexp_internal);
6734     if ( r == NULL || ri == NULL )
6735         FAIL("Regexp out of space");
6736 #ifdef DEBUGGING
6737     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
6738     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
6739          char);
6740 #else
6741     /* bulk initialize base fields with 0. */
6742     Zero(ri, sizeof(regexp_internal), char);
6743 #endif
6744
6745     /* non-zero initialization begins here */
6746     RXi_SET( r, ri );
6747     r->engine= eng;
6748     r->extflags = rx_flags;
6749     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
6750
6751     if (pm_flags & PMf_IS_QR) {
6752         ri->code_blocks = pRExC_state->code_blocks;
6753         ri->num_code_blocks = pRExC_state->num_code_blocks;
6754     }
6755     else
6756     {
6757         int n;
6758         for (n = 0; n < pRExC_state->num_code_blocks; n++)
6759             if (pRExC_state->code_blocks[n].src_regex)
6760                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
6761         SAVEFREEPV(pRExC_state->code_blocks);
6762     }
6763
6764     {
6765         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
6766         bool has_charset = (get_regex_charset(r->extflags)
6767                                                     != REGEX_DEPENDS_CHARSET);
6768
6769         /* The caret is output if there are any defaults: if not all the STD
6770          * flags are set, or if no character set specifier is needed */
6771         bool has_default =
6772                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
6773                     || ! has_charset);
6774         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
6775                                                    == REG_RUN_ON_COMMENT_SEEN);
6776         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
6777                             >> RXf_PMf_STD_PMMOD_SHIFT);
6778         const char *fptr = STD_PAT_MODS;        /*"msixn"*/
6779         char *p;
6780         /* Allocate for the worst case, which is all the std flags are turned
6781          * on.  If more precision is desired, we could do a population count of
6782          * the flags set.  This could be done with a small lookup table, or by
6783          * shifting, masking and adding, or even, when available, assembly
6784          * language for a machine-language population count.
6785          * We never output a minus, as all those are defaults, so are
6786          * covered by the caret */
6787         const STRLEN wraplen = plen + has_p + has_runon
6788             + has_default       /* If needs a caret */
6789
6790                 /* If needs a character set specifier */
6791             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
6792             + (sizeof(STD_PAT_MODS) - 1)
6793             + (sizeof("(?:)") - 1);
6794
6795         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
6796         r->xpv_len_u.xpvlenu_pv = p;
6797         if (RExC_utf8)
6798             SvFLAGS(rx) |= SVf_UTF8;
6799         *p++='('; *p++='?';
6800
6801         /* If a default, cover it using the caret */
6802         if (has_default) {
6803             *p++= DEFAULT_PAT_MOD;
6804         }
6805         if (has_charset) {
6806             STRLEN len;
6807             const char* const name = get_regex_charset_name(r->extflags, &len);
6808             Copy(name, p, len, char);
6809             p += len;
6810         }
6811         if (has_p)
6812             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
6813         {
6814             char ch;
6815             while((ch = *fptr++)) {
6816                 if(reganch & 1)
6817                     *p++ = ch;
6818                 reganch >>= 1;
6819             }
6820         }
6821
6822         *p++ = ':';
6823         Copy(RExC_precomp, p, plen, char);
6824         assert ((RX_WRAPPED(rx) - p) < 16);
6825         r->pre_prefix = p - RX_WRAPPED(rx);
6826         p += plen;
6827         if (has_runon)
6828             *p++ = '\n';
6829         *p++ = ')';
6830         *p = 0;
6831         SvCUR_set(rx, p - RX_WRAPPED(rx));
6832     }
6833
6834     r->intflags = 0;
6835     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
6836
6837     /* setup various meta data about recursion, this all requires
6838      * RExC_npar to be correctly set, and a bit later on we clear it */
6839     if (RExC_seen & REG_RECURSE_SEEN) {
6840         Newxz(RExC_open_parens, RExC_npar,regnode *);
6841         SAVEFREEPV(RExC_open_parens);
6842         Newxz(RExC_close_parens,RExC_npar,regnode *);
6843         SAVEFREEPV(RExC_close_parens);
6844     }
6845     if (RExC_seen & (REG_RECURSE_SEEN | REG_GOSTART_SEEN)) {
6846         /* Note, RExC_npar is 1 + the number of parens in a pattern.
6847          * So its 1 if there are no parens. */
6848         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
6849                                          ((RExC_npar & 0x07) != 0);
6850         Newx(RExC_study_chunk_recursed,
6851              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
6852         SAVEFREEPV(RExC_study_chunk_recursed);
6853     }
6854
6855     /* Useful during FAIL. */
6856 #ifdef RE_TRACK_PATTERN_OFFSETS
6857     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
6858     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
6859                           "%s %"UVuf" bytes for offset annotations.\n",
6860                           ri->u.offsets ? "Got" : "Couldn't get",
6861                           (UV)((2*RExC_size+1) * sizeof(U32))));
6862 #endif
6863     SetProgLen(ri,RExC_size);
6864     RExC_rx_sv = rx;
6865     RExC_rx = r;
6866     RExC_rxi = ri;
6867
6868     /* Second pass: emit code. */
6869     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
6870     RExC_pm_flags = pm_flags;
6871     RExC_parse = exp;
6872     RExC_end = exp + plen;
6873     RExC_naughty = 0;
6874     RExC_npar = 1;
6875     RExC_emit_start = ri->program;
6876     RExC_emit = ri->program;
6877     RExC_emit_bound = ri->program + RExC_size + 1;
6878     pRExC_state->code_index = 0;
6879
6880     *((char*) RExC_emit++) = (char) REG_MAGIC;
6881     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6882         ReREFCNT_dec(rx);
6883         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags);
6884     }
6885     /* XXXX To minimize changes to RE engine we always allocate
6886        3-units-long substrs field. */
6887     Newx(r->substrs, 1, struct reg_substr_data);
6888     if (RExC_recurse_count) {
6889         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
6890         SAVEFREEPV(RExC_recurse);
6891     }
6892
6893   reStudy:
6894     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
6895     DEBUG_r(
6896         RExC_study_chunk_recursed_count= 0;
6897     );
6898     Zero(r->substrs, 1, struct reg_substr_data);
6899     if (RExC_study_chunk_recursed) {
6900         Zero(RExC_study_chunk_recursed,
6901              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
6902     }
6903
6904
6905 #ifdef TRIE_STUDY_OPT
6906     if (!restudied) {
6907         StructCopy(&zero_scan_data, &data, scan_data_t);
6908         copyRExC_state = RExC_state;
6909     } else {
6910         U32 seen=RExC_seen;
6911         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
6912
6913         RExC_state = copyRExC_state;
6914         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
6915             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
6916         else
6917             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
6918         StructCopy(&zero_scan_data, &data, scan_data_t);
6919     }
6920 #else
6921     StructCopy(&zero_scan_data, &data, scan_data_t);
6922 #endif
6923
6924     /* Dig out information for optimizations. */
6925     r->extflags = RExC_flags; /* was pm_op */
6926     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
6927
6928     if (UTF)
6929         SvUTF8_on(rx);  /* Unicode in it? */
6930     ri->regstclass = NULL;
6931     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
6932         r->intflags |= PREGf_NAUGHTY;
6933     scan = ri->program + 1;             /* First BRANCH. */
6934
6935     /* testing for BRANCH here tells us whether there is "must appear"
6936        data in the pattern. If there is then we can use it for optimisations */
6937     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
6938                                                   */
6939         SSize_t fake;
6940         STRLEN longest_float_length, longest_fixed_length;
6941         regnode_ssc ch_class; /* pointed to by data */
6942         int stclass_flag;
6943         SSize_t last_close = 0; /* pointed to by data */
6944         regnode *first= scan;
6945         regnode *first_next= regnext(first);
6946         /*
6947          * Skip introductions and multiplicators >= 1
6948          * so that we can extract the 'meat' of the pattern that must
6949          * match in the large if() sequence following.
6950          * NOTE that EXACT is NOT covered here, as it is normally
6951          * picked up by the optimiser separately.
6952          *
6953          * This is unfortunate as the optimiser isnt handling lookahead
6954          * properly currently.
6955          *
6956          */
6957         while ((OP(first) == OPEN && (sawopen = 1)) ||
6958                /* An OR of *one* alternative - should not happen now. */
6959             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6960             /* for now we can't handle lookbehind IFMATCH*/
6961             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6962             (OP(first) == PLUS) ||
6963             (OP(first) == MINMOD) ||
6964                /* An {n,m} with n>0 */
6965             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6966             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6967         {
6968                 /*
6969                  * the only op that could be a regnode is PLUS, all the rest
6970                  * will be regnode_1 or regnode_2.
6971                  *
6972                  * (yves doesn't think this is true)
6973                  */
6974                 if (OP(first) == PLUS)
6975                     sawplus = 1;
6976                 else {
6977                     if (OP(first) == MINMOD)
6978                         sawminmod = 1;
6979                     first += regarglen[OP(first)];
6980                 }
6981                 first = NEXTOPER(first);
6982                 first_next= regnext(first);
6983         }
6984
6985         /* Starting-point info. */
6986       again:
6987         DEBUG_PEEP("first:",first,0);
6988         /* Ignore EXACT as we deal with it later. */
6989         if (PL_regkind[OP(first)] == EXACT) {
6990             if (OP(first) == EXACT || OP(first) == EXACTL)
6991                 NOOP;   /* Empty, get anchored substr later. */
6992             else
6993                 ri->regstclass = first;
6994         }
6995 #ifdef TRIE_STCLASS
6996         else if (PL_regkind[OP(first)] == TRIE &&
6997                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
6998         {
6999             /* this can happen only on restudy */
7000             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7001         }
7002 #endif
7003         else if (REGNODE_SIMPLE(OP(first)))
7004             ri->regstclass = first;
7005         else if (PL_regkind[OP(first)] == BOUND ||
7006                  PL_regkind[OP(first)] == NBOUND)
7007             ri->regstclass = first;
7008         else if (PL_regkind[OP(first)] == BOL) {
7009             r->intflags |= (OP(first) == MBOL
7010                            ? PREGf_ANCH_MBOL
7011                            : PREGf_ANCH_SBOL);
7012             first = NEXTOPER(first);
7013             goto again;
7014         }
7015         else if (OP(first) == GPOS) {
7016             r->intflags |= PREGf_ANCH_GPOS;
7017             first = NEXTOPER(first);
7018             goto again;
7019         }
7020         else if ((!sawopen || !RExC_sawback) &&
7021             !sawlookahead &&
7022             (OP(first) == STAR &&
7023             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7024             !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
7025         {
7026             /* turn .* into ^.* with an implied $*=1 */
7027             const int type =
7028                 (OP(NEXTOPER(first)) == REG_ANY)
7029                     ? PREGf_ANCH_MBOL
7030                     : PREGf_ANCH_SBOL;
7031             r->intflags |= (type | PREGf_IMPLICIT);
7032             first = NEXTOPER(first);
7033             goto again;
7034         }
7035         if (sawplus && !sawminmod && !sawlookahead
7036             && (!sawopen || !RExC_sawback)
7037             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
7038             /* x+ must match at the 1st pos of run of x's */
7039             r->intflags |= PREGf_SKIP;
7040
7041         /* Scan is after the zeroth branch, first is atomic matcher. */
7042 #ifdef TRIE_STUDY_OPT
7043         DEBUG_PARSE_r(
7044             if (!restudied)
7045                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
7046                               (IV)(first - scan + 1))
7047         );
7048 #else
7049         DEBUG_PARSE_r(
7050             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
7051                 (IV)(first - scan + 1))
7052         );
7053 #endif
7054
7055
7056         /*
7057         * If there's something expensive in the r.e., find the
7058         * longest literal string that must appear and make it the
7059         * regmust.  Resolve ties in favor of later strings, since
7060         * the regstart check works with the beginning of the r.e.
7061         * and avoiding duplication strengthens checking.  Not a
7062         * strong reason, but sufficient in the absence of others.
7063         * [Now we resolve ties in favor of the earlier string if
7064         * it happens that c_offset_min has been invalidated, since the
7065         * earlier string may buy us something the later one won't.]
7066         */
7067
7068         data.longest_fixed = newSVpvs("");
7069         data.longest_float = newSVpvs("");
7070         data.last_found = newSVpvs("");
7071         data.longest = &(data.longest_fixed);
7072         ENTER_with_name("study_chunk");
7073         SAVEFREESV(data.longest_fixed);
7074         SAVEFREESV(data.longest_float);
7075         SAVEFREESV(data.last_found);
7076         first = scan;
7077         if (!ri->regstclass) {
7078             ssc_init(pRExC_state, &ch_class);
7079             data.start_class = &ch_class;
7080             stclass_flag = SCF_DO_STCLASS_AND;
7081         } else                          /* XXXX Check for BOUND? */
7082             stclass_flag = 0;
7083         data.last_closep = &last_close;
7084
7085         DEBUG_RExC_seen();
7086         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7087                              scan + RExC_size, /* Up to end */
7088             &data, -1, 0, NULL,
7089             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7090                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7091             0);
7092
7093
7094         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7095
7096
7097         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
7098              && data.last_start_min == 0 && data.last_end > 0
7099              && !RExC_seen_zerolen
7100              && !(RExC_seen & REG_VERBARG_SEEN)
7101              && !(RExC_seen & REG_GPOS_SEEN)
7102         ){
7103             r->extflags |= RXf_CHECK_ALL;
7104         }
7105         scan_commit(pRExC_state, &data,&minlen,0);
7106
7107         longest_float_length = CHR_SVLEN(data.longest_float);
7108
7109         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
7110                    && data.offset_fixed == data.offset_float_min
7111                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
7112             && S_setup_longest (aTHX_ pRExC_state,
7113                                     data.longest_float,
7114                                     &(r->float_utf8),
7115                                     &(r->float_substr),
7116                                     &(r->float_end_shift),
7117                                     data.lookbehind_float,
7118                                     data.offset_float_min,
7119                                     data.minlen_float,
7120                                     longest_float_length,
7121                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
7122                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
7123         {
7124             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
7125             r->float_max_offset = data.offset_float_max;
7126             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
7127                 r->float_max_offset -= data.lookbehind_float;
7128             SvREFCNT_inc_simple_void_NN(data.longest_float);
7129         }
7130         else {
7131             r->float_substr = r->float_utf8 = NULL;
7132             longest_float_length = 0;
7133         }
7134
7135         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
7136
7137         if (S_setup_longest (aTHX_ pRExC_state,
7138                                 data.longest_fixed,
7139                                 &(r->anchored_utf8),
7140                                 &(r->anchored_substr),
7141                                 &(r->anchored_end_shift),
7142                                 data.lookbehind_fixed,
7143                                 data.offset_fixed,
7144                                 data.minlen_fixed,
7145                                 longest_fixed_length,
7146                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7147                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7148         {
7149             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7150             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7151         }
7152         else {
7153             r->anchored_substr = r->anchored_utf8 = NULL;
7154             longest_fixed_length = 0;
7155         }
7156         LEAVE_with_name("study_chunk");
7157
7158         if (ri->regstclass
7159             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7160             ri->regstclass = NULL;
7161
7162         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7163             && stclass_flag
7164             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7165             && is_ssc_worth_it(pRExC_state, data.start_class))
7166         {
7167             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7168
7169             ssc_finalize(pRExC_state, data.start_class);
7170
7171             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7172             StructCopy(data.start_class,
7173                        (regnode_ssc*)RExC_rxi->data->data[n],
7174                        regnode_ssc);
7175             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7176             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7177             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7178                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7179                       PerlIO_printf(Perl_debug_log,
7180                                     "synthetic stclass \"%s\".\n",
7181                                     SvPVX_const(sv));});
7182             data.start_class = NULL;
7183         }
7184
7185         /* A temporary algorithm prefers floated substr to fixed one to dig
7186          * more info. */
7187         if (longest_fixed_length > longest_float_length) {
7188             r->substrs->check_ix = 0;
7189             r->check_end_shift = r->anchored_end_shift;
7190             r->check_substr = r->anchored_substr;
7191             r->check_utf8 = r->anchored_utf8;
7192             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7193             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7194                 r->intflags |= PREGf_NOSCAN;
7195         }
7196         else {
7197             r->substrs->check_ix = 1;
7198             r->check_end_shift = r->float_end_shift;
7199             r->check_substr = r->float_substr;
7200             r->check_utf8 = r->float_utf8;
7201             r->check_offset_min = r->float_min_offset;
7202             r->check_offset_max = r->float_max_offset;
7203         }
7204         if ((r->check_substr || r->check_utf8) ) {
7205             r->extflags |= RXf_USE_INTUIT;
7206             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7207                 r->extflags |= RXf_INTUIT_TAIL;
7208         }
7209         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7210
7211         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7212         if ( (STRLEN)minlen < longest_float_length )
7213             minlen= longest_float_length;
7214         if ( (STRLEN)minlen < longest_fixed_length )
7215             minlen= longest_fixed_length;
7216         */
7217     }
7218     else {
7219         /* Several toplevels. Best we can is to set minlen. */
7220         SSize_t fake;
7221         regnode_ssc ch_class;
7222         SSize_t last_close = 0;
7223
7224         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
7225
7226         scan = ri->program + 1;
7227         ssc_init(pRExC_state, &ch_class);
7228         data.start_class = &ch_class;
7229         data.last_closep = &last_close;
7230
7231         DEBUG_RExC_seen();
7232         minlen = study_chunk(pRExC_state,
7233             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7234             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7235                                                       ? SCF_TRIE_DOING_RESTUDY
7236                                                       : 0),
7237             0);
7238
7239         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7240
7241         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7242                 = r->float_substr = r->float_utf8 = NULL;
7243
7244         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7245             && is_ssc_worth_it(pRExC_state, data.start_class))
7246         {
7247             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7248
7249             ssc_finalize(pRExC_state, data.start_class);
7250
7251             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7252             StructCopy(data.start_class,
7253                        (regnode_ssc*)RExC_rxi->data->data[n],
7254                        regnode_ssc);
7255             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7256             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7257             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7258                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7259                       PerlIO_printf(Perl_debug_log,
7260                                     "synthetic stclass \"%s\".\n",
7261                                     SvPVX_const(sv));});
7262             data.start_class = NULL;
7263         }
7264     }
7265
7266     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7267         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7268         r->maxlen = REG_INFTY;
7269     }
7270     else {
7271         r->maxlen = RExC_maxlen;
7272     }
7273
7274     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7275        the "real" pattern. */
7276     DEBUG_OPTIMISE_r({
7277         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%"IVdf"\n",
7278                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7279     });
7280     r->minlenret = minlen;
7281     if (r->minlen < minlen)
7282         r->minlen = minlen;
7283
7284     if (RExC_seen & REG_GPOS_SEEN)
7285         r->intflags |= PREGf_GPOS_SEEN;
7286     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7287         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7288                                                 lookbehind */
7289     if (pRExC_state->num_code_blocks)
7290         r->extflags |= RXf_EVAL_SEEN;
7291     if (RExC_seen & REG_CANY_SEEN)
7292         r->intflags |= PREGf_CANY_SEEN;
7293     if (RExC_seen & REG_VERBARG_SEEN)
7294     {
7295         r->intflags |= PREGf_VERBARG_SEEN;
7296         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7297     }
7298     if (RExC_seen & REG_CUTGROUP_SEEN)
7299         r->intflags |= PREGf_CUTGROUP_SEEN;
7300     if (pm_flags & PMf_USE_RE_EVAL)
7301         r->intflags |= PREGf_USE_RE_EVAL;
7302     if (RExC_paren_names)
7303         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7304     else
7305         RXp_PAREN_NAMES(r) = NULL;
7306
7307     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7308      * so it can be used in pp.c */
7309     if (r->intflags & PREGf_ANCH)
7310         r->extflags |= RXf_IS_ANCHORED;
7311
7312
7313     {
7314         /* this is used to identify "special" patterns that might result
7315          * in Perl NOT calling the regex engine and instead doing the match "itself",
7316          * particularly special cases in split//. By having the regex compiler
7317          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7318          * we avoid weird issues with equivalent patterns resulting in different behavior,
7319          * AND we allow non Perl engines to get the same optimizations by the setting the
7320          * flags appropriately - Yves */
7321         regnode *first = ri->program + 1;
7322         U8 fop = OP(first);
7323         regnode *next = regnext(first);
7324         U8 nop = OP(next);
7325
7326         if (PL_regkind[fop] == NOTHING && nop == END)
7327             r->extflags |= RXf_NULL;
7328         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7329             /* when fop is SBOL first->flags will be true only when it was
7330              * produced by parsing /\A/, and not when parsing /^/. This is
7331              * very important for the split code as there we want to
7332              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7333              * See rt #122761 for more details. -- Yves */
7334             r->extflags |= RXf_START_ONLY;
7335         else if (fop == PLUS
7336                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7337                  && nop == END)
7338             r->extflags |= RXf_WHITE;
7339         else if ( r->extflags & RXf_SPLIT
7340                   && (fop == EXACT || fop == EXACTL)
7341                   && STR_LEN(first) == 1
7342                   && *(STRING(first)) == ' '
7343                   && nop == END )
7344             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7345
7346     }
7347
7348     if (RExC_contains_locale) {
7349         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7350     }
7351
7352 #ifdef DEBUGGING
7353     if (RExC_paren_names) {
7354         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7355         ri->data->data[ri->name_list_idx]
7356                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7357     } else
7358 #endif
7359         ri->name_list_idx = 0;
7360
7361     if (RExC_recurse_count) {
7362         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
7363             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
7364             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
7365         }
7366     }
7367     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7368     /* assume we don't need to swap parens around before we match */
7369     DEBUG_TEST_r({
7370         PerlIO_printf(Perl_debug_log,"study_chunk_recursed_count: %lu\n",
7371             (unsigned long)RExC_study_chunk_recursed_count);
7372     });
7373     DEBUG_DUMP_r({
7374         DEBUG_RExC_seen();
7375         PerlIO_printf(Perl_debug_log,"Final program:\n");
7376         regdump(r);
7377     });
7378 #ifdef RE_TRACK_PATTERN_OFFSETS
7379     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7380         const STRLEN len = ri->u.offsets[0];
7381         STRLEN i;
7382         GET_RE_DEBUG_FLAGS_DECL;
7383         PerlIO_printf(Perl_debug_log,
7384                       "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
7385         for (i = 1; i <= len; i++) {
7386             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7387                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
7388                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7389             }
7390         PerlIO_printf(Perl_debug_log, "\n");
7391     });
7392 #endif
7393
7394 #ifdef USE_ITHREADS
7395     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7396      * by setting the regexp SV to readonly-only instead. If the
7397      * pattern's been recompiled, the USEDness should remain. */
7398     if (old_re && SvREADONLY(old_re))
7399         SvREADONLY_on(rx);
7400 #endif
7401     return rx;
7402 }
7403
7404
7405 SV*
7406 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7407                     const U32 flags)
7408 {
7409     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7410
7411     PERL_UNUSED_ARG(value);
7412
7413     if (flags & RXapif_FETCH) {
7414         return reg_named_buff_fetch(rx, key, flags);
7415     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7416         Perl_croak_no_modify();
7417         return NULL;
7418     } else if (flags & RXapif_EXISTS) {
7419         return reg_named_buff_exists(rx, key, flags)
7420             ? &PL_sv_yes
7421             : &PL_sv_no;
7422     } else if (flags & RXapif_REGNAMES) {
7423         return reg_named_buff_all(rx, flags);
7424     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7425         return reg_named_buff_scalar(rx, flags);
7426     } else {
7427         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7428         return NULL;
7429     }
7430 }
7431
7432 SV*
7433 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7434                          const U32 flags)
7435 {
7436     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7437     PERL_UNUSED_ARG(lastkey);
7438
7439     if (flags & RXapif_FIRSTKEY)
7440         return reg_named_buff_firstkey(rx, flags);
7441     else if (flags & RXapif_NEXTKEY)
7442         return reg_named_buff_nextkey(rx, flags);
7443     else {
7444         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7445                                             (int)flags);
7446         return NULL;
7447     }
7448 }
7449
7450 SV*
7451 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7452                           const U32 flags)
7453 {
7454     AV *retarray = NULL;
7455     SV *ret;
7456     struct regexp *const rx = ReANY(r);
7457
7458     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7459
7460     if (flags & RXapif_ALL)
7461         retarray=newAV();
7462
7463     if (rx && RXp_PAREN_NAMES(rx)) {
7464         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7465         if (he_str) {
7466             IV i;
7467             SV* sv_dat=HeVAL(he_str);
7468             I32 *nums=(I32*)SvPVX(sv_dat);
7469             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7470                 if ((I32)(rx->nparens) >= nums[i]
7471                     && rx->offs[nums[i]].start != -1
7472                     && rx->offs[nums[i]].end != -1)
7473                 {
7474                     ret = newSVpvs("");
7475                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7476                     if (!retarray)
7477                         return ret;
7478                 } else {
7479                     if (retarray)
7480                         ret = newSVsv(&PL_sv_undef);
7481                 }
7482                 if (retarray)
7483                     av_push(retarray, ret);
7484             }
7485             if (retarray)
7486                 return newRV_noinc(MUTABLE_SV(retarray));
7487         }
7488     }
7489     return NULL;
7490 }
7491
7492 bool
7493 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7494                            const U32 flags)
7495 {
7496     struct regexp *const rx = ReANY(r);
7497
7498     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7499
7500     if (rx && RXp_PAREN_NAMES(rx)) {
7501         if (flags & RXapif_ALL) {
7502             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7503         } else {
7504             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7505             if (sv) {
7506                 SvREFCNT_dec_NN(sv);
7507                 return TRUE;
7508             } else {
7509                 return FALSE;
7510             }
7511         }
7512     } else {
7513         return FALSE;
7514     }
7515 }
7516
7517 SV*
7518 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7519 {
7520     struct regexp *const rx = ReANY(r);
7521
7522     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7523
7524     if ( rx && RXp_PAREN_NAMES(rx) ) {
7525         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7526
7527         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7528     } else {
7529         return FALSE;
7530     }
7531 }
7532
7533 SV*
7534 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7535 {
7536     struct regexp *const rx = ReANY(r);
7537     GET_RE_DEBUG_FLAGS_DECL;
7538
7539     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7540
7541     if (rx && RXp_PAREN_NAMES(rx)) {
7542         HV *hv = RXp_PAREN_NAMES(rx);
7543         HE *temphe;
7544         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7545             IV i;
7546             IV parno = 0;
7547             SV* sv_dat = HeVAL(temphe);
7548             I32 *nums = (I32*)SvPVX(sv_dat);
7549             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7550                 if ((I32)(rx->lastparen) >= nums[i] &&
7551                     rx->offs[nums[i]].start != -1 &&
7552                     rx->offs[nums[i]].end != -1)
7553                 {
7554                     parno = nums[i];
7555                     break;
7556                 }
7557             }
7558             if (parno || flags & RXapif_ALL) {
7559                 return newSVhek(HeKEY_hek(temphe));
7560             }
7561         }
7562     }
7563     return NULL;
7564 }
7565
7566 SV*
7567 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
7568 {
7569     SV *ret;
7570     AV *av;
7571     SSize_t length;
7572     struct regexp *const rx = ReANY(r);
7573
7574     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
7575
7576     if (rx && RXp_PAREN_NAMES(rx)) {
7577         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
7578             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
7579         } else if (flags & RXapif_ONE) {
7580             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
7581             av = MUTABLE_AV(SvRV(ret));
7582             length = av_tindex(av);
7583             SvREFCNT_dec_NN(ret);
7584             return newSViv(length + 1);
7585         } else {
7586             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
7587                                                 (int)flags);
7588             return NULL;
7589         }
7590     }
7591     return &PL_sv_undef;
7592 }
7593
7594 SV*
7595 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
7596 {
7597     struct regexp *const rx = ReANY(r);
7598     AV *av = newAV();
7599
7600     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
7601
7602     if (rx && RXp_PAREN_NAMES(rx)) {
7603         HV *hv= RXp_PAREN_NAMES(rx);
7604         HE *temphe;
7605         (void)hv_iterinit(hv);
7606         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7607             IV i;
7608             IV parno = 0;
7609             SV* sv_dat = HeVAL(temphe);
7610             I32 *nums = (I32*)SvPVX(sv_dat);
7611             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7612                 if ((I32)(rx->lastparen) >= nums[i] &&
7613                     rx->offs[nums[i]].start != -1 &&
7614                     rx->offs[nums[i]].end != -1)
7615                 {
7616                     parno = nums[i];
7617                     break;
7618                 }
7619             }
7620             if (parno || flags & RXapif_ALL) {
7621                 av_push(av, newSVhek(HeKEY_hek(temphe)));
7622             }
7623         }
7624     }
7625
7626     return newRV_noinc(MUTABLE_SV(av));
7627 }
7628
7629 void
7630 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
7631                              SV * const sv)
7632 {
7633     struct regexp *const rx = ReANY(r);
7634     char *s = NULL;
7635     SSize_t i = 0;
7636     SSize_t s1, t1;
7637     I32 n = paren;
7638
7639     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
7640
7641     if (      n == RX_BUFF_IDX_CARET_PREMATCH
7642            || n == RX_BUFF_IDX_CARET_FULLMATCH
7643            || n == RX_BUFF_IDX_CARET_POSTMATCH
7644        )
7645     {
7646         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
7647         if (!keepcopy) {
7648             /* on something like
7649              *    $r = qr/.../;
7650              *    /$qr/p;
7651              * the KEEPCOPY is set on the PMOP rather than the regex */
7652             if (PL_curpm && r == PM_GETRE(PL_curpm))
7653                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
7654         }
7655         if (!keepcopy)
7656             goto ret_undef;
7657     }
7658
7659     if (!rx->subbeg)
7660         goto ret_undef;
7661
7662     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
7663         /* no need to distinguish between them any more */
7664         n = RX_BUFF_IDX_FULLMATCH;
7665
7666     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
7667         && rx->offs[0].start != -1)
7668     {
7669         /* $`, ${^PREMATCH} */
7670         i = rx->offs[0].start;
7671         s = rx->subbeg;
7672     }
7673     else
7674     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
7675         && rx->offs[0].end != -1)
7676     {
7677         /* $', ${^POSTMATCH} */
7678         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
7679         i = rx->sublen + rx->suboffset - rx->offs[0].end;
7680     }
7681     else
7682     if ( 0 <= n && n <= (I32)rx->nparens &&
7683         (s1 = rx->offs[n].start) != -1 &&
7684         (t1 = rx->offs[n].end) != -1)
7685     {
7686         /* $&, ${^MATCH},  $1 ... */
7687         i = t1 - s1;
7688         s = rx->subbeg + s1 - rx->suboffset;
7689     } else {
7690         goto ret_undef;
7691     }
7692
7693     assert(s >= rx->subbeg);
7694     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
7695     if (i >= 0) {
7696 #ifdef NO_TAINT_SUPPORT
7697         sv_setpvn(sv, s, i);
7698 #else
7699         const int oldtainted = TAINT_get;
7700         TAINT_NOT;
7701         sv_setpvn(sv, s, i);
7702         TAINT_set(oldtainted);
7703 #endif
7704         if ( (rx->intflags & PREGf_CANY_SEEN)
7705             ? (RXp_MATCH_UTF8(rx)
7706                         && (!i || is_utf8_string((U8*)s, i)))
7707             : (RXp_MATCH_UTF8(rx)) )
7708         {
7709             SvUTF8_on(sv);
7710         }
7711         else
7712             SvUTF8_off(sv);
7713         if (TAINTING_get) {
7714             if (RXp_MATCH_TAINTED(rx)) {
7715                 if (SvTYPE(sv) >= SVt_PVMG) {
7716                     MAGIC* const mg = SvMAGIC(sv);
7717                     MAGIC* mgt;
7718                     TAINT;
7719                     SvMAGIC_set(sv, mg->mg_moremagic);
7720                     SvTAINT(sv);
7721                     if ((mgt = SvMAGIC(sv))) {
7722                         mg->mg_moremagic = mgt;
7723                         SvMAGIC_set(sv, mg);
7724                     }
7725                 } else {
7726                     TAINT;
7727                     SvTAINT(sv);
7728                 }
7729             } else
7730                 SvTAINTED_off(sv);
7731         }
7732     } else {
7733       ret_undef:
7734         sv_setsv(sv,&PL_sv_undef);
7735         return;
7736     }
7737 }
7738
7739 void
7740 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
7741                                                          SV const * const value)
7742 {
7743     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
7744
7745     PERL_UNUSED_ARG(rx);
7746     PERL_UNUSED_ARG(paren);
7747     PERL_UNUSED_ARG(value);
7748
7749     if (!PL_localizing)
7750         Perl_croak_no_modify();
7751 }
7752
7753 I32
7754 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
7755                               const I32 paren)
7756 {
7757     struct regexp *const rx = ReANY(r);
7758     I32 i;
7759     I32 s1, t1;
7760
7761     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
7762
7763     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
7764         || paren == RX_BUFF_IDX_CARET_FULLMATCH
7765         || paren == RX_BUFF_IDX_CARET_POSTMATCH
7766     )
7767     {
7768         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
7769         if (!keepcopy) {
7770             /* on something like
7771              *    $r = qr/.../;
7772              *    /$qr/p;
7773              * the KEEPCOPY is set on the PMOP rather than the regex */
7774             if (PL_curpm && r == PM_GETRE(PL_curpm))
7775                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
7776         }
7777         if (!keepcopy)
7778             goto warn_undef;
7779     }
7780
7781     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
7782     switch (paren) {
7783       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
7784       case RX_BUFF_IDX_PREMATCH:       /* $` */
7785         if (rx->offs[0].start != -1) {
7786                         i = rx->offs[0].start;
7787                         if (i > 0) {
7788                                 s1 = 0;
7789                                 t1 = i;
7790                                 goto getlen;
7791                         }
7792             }
7793         return 0;
7794
7795       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
7796       case RX_BUFF_IDX_POSTMATCH:       /* $' */
7797             if (rx->offs[0].end != -1) {
7798                         i = rx->sublen - rx->offs[0].end;
7799                         if (i > 0) {
7800                                 s1 = rx->offs[0].end;
7801                                 t1 = rx->sublen;
7802                                 goto getlen;
7803                         }
7804             }
7805         return 0;
7806
7807       default: /* $& / ${^MATCH}, $1, $2, ... */
7808             if (paren <= (I32)rx->nparens &&
7809             (s1 = rx->offs[paren].start) != -1 &&
7810             (t1 = rx->offs[paren].end) != -1)
7811             {
7812             i = t1 - s1;
7813             goto getlen;
7814         } else {
7815           warn_undef:
7816             if (ckWARN(WARN_UNINITIALIZED))
7817                 report_uninit((const SV *)sv);
7818             return 0;
7819         }
7820     }
7821   getlen:
7822     if (i > 0 && RXp_MATCH_UTF8(rx)) {
7823         const char * const s = rx->subbeg - rx->suboffset + s1;
7824         const U8 *ep;
7825         STRLEN el;
7826
7827         i = t1 - s1;
7828         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
7829                         i = el;
7830     }
7831     return i;
7832 }
7833
7834 SV*
7835 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
7836 {
7837     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
7838         PERL_UNUSED_ARG(rx);
7839         if (0)
7840             return NULL;
7841         else
7842             return newSVpvs("Regexp");
7843 }
7844
7845 /* Scans the name of a named buffer from the pattern.
7846  * If flags is REG_RSN_RETURN_NULL returns null.
7847  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
7848  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
7849  * to the parsed name as looked up in the RExC_paren_names hash.
7850  * If there is an error throws a vFAIL().. type exception.
7851  */
7852
7853 #define REG_RSN_RETURN_NULL    0
7854 #define REG_RSN_RETURN_NAME    1
7855 #define REG_RSN_RETURN_DATA    2
7856
7857 STATIC SV*
7858 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
7859 {
7860     char *name_start = RExC_parse;
7861
7862     PERL_ARGS_ASSERT_REG_SCAN_NAME;
7863
7864     assert (RExC_parse <= RExC_end);
7865     if (RExC_parse == RExC_end) NOOP;
7866     else if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
7867          /* skip IDFIRST by using do...while */
7868         if (UTF)
7869             do {
7870                 RExC_parse += UTF8SKIP(RExC_parse);
7871             } while (isWORDCHAR_utf8((U8*)RExC_parse));
7872         else
7873             do {
7874                 RExC_parse++;
7875             } while (isWORDCHAR(*RExC_parse));
7876     } else {
7877         RExC_parse++; /* so the <- from the vFAIL is after the offending
7878                          character */
7879         vFAIL("Group name must start with a non-digit word character");
7880     }
7881     if ( flags ) {
7882         SV* sv_name
7883             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
7884                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
7885         if ( flags == REG_RSN_RETURN_NAME)
7886             return sv_name;
7887         else if (flags==REG_RSN_RETURN_DATA) {
7888             HE *he_str = NULL;
7889             SV *sv_dat = NULL;
7890             if ( ! sv_name )      /* should not happen*/
7891                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
7892             if (RExC_paren_names)
7893                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
7894             if ( he_str )
7895                 sv_dat = HeVAL(he_str);
7896             if ( ! sv_dat )
7897                 vFAIL("Reference to nonexistent named group");
7898             return sv_dat;
7899         }
7900         else {
7901             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
7902                        (unsigned long) flags);
7903         }
7904         NOT_REACHED; /* NOTREACHED */
7905     }
7906     return NULL;
7907 }
7908
7909 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
7910     int num;                                                    \
7911     if (RExC_lastparse!=RExC_parse) {                           \
7912         PerlIO_printf(Perl_debug_log, "%s",                     \
7913             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
7914                 RExC_end - RExC_parse, 16,                      \
7915                 "", "",                                         \
7916                 PERL_PV_ESCAPE_UNI_DETECT |                     \
7917                 PERL_PV_PRETTY_ELLIPSES   |                     \
7918                 PERL_PV_PRETTY_LTGT       |                     \
7919                 PERL_PV_ESCAPE_RE         |                     \
7920                 PERL_PV_PRETTY_EXACTSIZE                        \
7921             )                                                   \
7922         );                                                      \
7923     } else                                                      \
7924         PerlIO_printf(Perl_debug_log,"%16s","");                \
7925                                                                 \
7926     if (SIZE_ONLY)                                              \
7927        num = RExC_size + 1;                                     \
7928     else                                                        \
7929        num=REG_NODE_NUM(RExC_emit);                             \
7930     if (RExC_lastnum!=num)                                      \
7931        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
7932     else                                                        \
7933        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
7934     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
7935         (int)((depth*2)), "",                                   \
7936         (funcname)                                              \
7937     );                                                          \
7938     RExC_lastnum=num;                                           \
7939     RExC_lastparse=RExC_parse;                                  \
7940 })
7941
7942
7943
7944 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
7945     DEBUG_PARSE_MSG((funcname));                            \
7946     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
7947 })
7948 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
7949     DEBUG_PARSE_MSG((funcname));                            \
7950     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
7951 })
7952
7953 /* This section of code defines the inversion list object and its methods.  The
7954  * interfaces are highly subject to change, so as much as possible is static to
7955  * this file.  An inversion list is here implemented as a malloc'd C UV array
7956  * as an SVt_INVLIST scalar.
7957  *
7958  * An inversion list for Unicode is an array of code points, sorted by ordinal
7959  * number.  The zeroth element is the first code point in the list.  The 1th
7960  * element is the first element beyond that not in the list.  In other words,
7961  * the first range is
7962  *  invlist[0]..(invlist[1]-1)
7963  * The other ranges follow.  Thus every element whose index is divisible by two
7964  * marks the beginning of a range that is in the list, and every element not
7965  * divisible by two marks the beginning of a range not in the list.  A single
7966  * element inversion list that contains the single code point N generally
7967  * consists of two elements
7968  *  invlist[0] == N
7969  *  invlist[1] == N+1
7970  * (The exception is when N is the highest representable value on the
7971  * machine, in which case the list containing just it would be a single
7972  * element, itself.  By extension, if the last range in the list extends to
7973  * infinity, then the first element of that range will be in the inversion list
7974  * at a position that is divisible by two, and is the final element in the
7975  * list.)
7976  * Taking the complement (inverting) an inversion list is quite simple, if the
7977  * first element is 0, remove it; otherwise add a 0 element at the beginning.
7978  * This implementation reserves an element at the beginning of each inversion
7979  * list to always contain 0; there is an additional flag in the header which
7980  * indicates if the list begins at the 0, or is offset to begin at the next
7981  * element.
7982  *
7983  * More about inversion lists can be found in "Unicode Demystified"
7984  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
7985  * More will be coming when functionality is added later.
7986  *
7987  * The inversion list data structure is currently implemented as an SV pointing
7988  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
7989  * array of UV whose memory management is automatically handled by the existing
7990  * facilities for SV's.
7991  *
7992  * Some of the methods should always be private to the implementation, and some
7993  * should eventually be made public */
7994
7995 /* The header definitions are in F<inline_invlist.c> */
7996
7997 PERL_STATIC_INLINE UV*
7998 S__invlist_array_init(SV* const invlist, const bool will_have_0)
7999 {
8000     /* Returns a pointer to the first element in the inversion list's array.
8001      * This is called upon initialization of an inversion list.  Where the
8002      * array begins depends on whether the list has the code point U+0000 in it
8003      * or not.  The other parameter tells it whether the code that follows this
8004      * call is about to put a 0 in the inversion list or not.  The first
8005      * element is either the element reserved for 0, if TRUE, or the element
8006      * after it, if FALSE */
8007
8008     bool* offset = get_invlist_offset_addr(invlist);
8009     UV* zero_addr = (UV *) SvPVX(invlist);
8010
8011     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8012
8013     /* Must be empty */
8014     assert(! _invlist_len(invlist));
8015
8016     *zero_addr = 0;
8017
8018     /* 1^1 = 0; 1^0 = 1 */
8019     *offset = 1 ^ will_have_0;
8020     return zero_addr + *offset;
8021 }
8022
8023 PERL_STATIC_INLINE void
8024 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8025 {
8026     /* Sets the current number of elements stored in the inversion list.
8027      * Updates SvCUR correspondingly */
8028     PERL_UNUSED_CONTEXT;
8029     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8030
8031     assert(SvTYPE(invlist) == SVt_INVLIST);
8032
8033     SvCUR_set(invlist,
8034               (len == 0)
8035                ? 0
8036                : TO_INTERNAL_SIZE(len + offset));
8037     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8038 }
8039
8040 #ifndef PERL_IN_XSUB_RE
8041
8042 PERL_STATIC_INLINE IV*
8043 S_get_invlist_previous_index_addr(SV* invlist)
8044 {
8045     /* Return the address of the IV that is reserved to hold the cached index
8046      * */
8047     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8048
8049     assert(SvTYPE(invlist) == SVt_INVLIST);
8050
8051     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8052 }
8053
8054 PERL_STATIC_INLINE IV
8055 S_invlist_previous_index(SV* const invlist)
8056 {
8057     /* Returns cached index of previous search */
8058
8059     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8060
8061     return *get_invlist_previous_index_addr(invlist);
8062 }
8063
8064 PERL_STATIC_INLINE void
8065 S_invlist_set_previous_index(SV* const invlist, const IV index)
8066 {
8067     /* Caches <index> for later retrieval */
8068
8069     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8070
8071     assert(index == 0 || index < (int) _invlist_len(invlist));
8072
8073     *get_invlist_previous_index_addr(invlist) = index;
8074 }
8075
8076 PERL_STATIC_INLINE void
8077 S_invlist_trim(SV* const invlist)
8078 {
8079     PERL_ARGS_ASSERT_INVLIST_TRIM;
8080
8081     assert(SvTYPE(invlist) == SVt_INVLIST);
8082
8083     /* Change the length of the inversion list to how many entries it currently
8084      * has */
8085     SvPV_shrink_to_cur((SV *) invlist);
8086 }
8087
8088 PERL_STATIC_INLINE bool
8089 S_invlist_is_iterating(SV* const invlist)
8090 {
8091     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8092
8093     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8094 }
8095
8096 #endif /* ifndef PERL_IN_XSUB_RE */
8097
8098 PERL_STATIC_INLINE UV
8099 S_invlist_max(SV* const invlist)
8100 {
8101     /* Returns the maximum number of elements storable in the inversion list's
8102      * array, without having to realloc() */
8103
8104     PERL_ARGS_ASSERT_INVLIST_MAX;
8105
8106     assert(SvTYPE(invlist) == SVt_INVLIST);
8107
8108     /* Assumes worst case, in which the 0 element is not counted in the
8109      * inversion list, so subtracts 1 for that */
8110     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8111            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8112            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8113 }
8114
8115 #ifndef PERL_IN_XSUB_RE
8116 SV*
8117 Perl__new_invlist(pTHX_ IV initial_size)
8118 {
8119
8120     /* Return a pointer to a newly constructed inversion list, with enough
8121      * space to store 'initial_size' elements.  If that number is negative, a
8122      * system default is used instead */
8123
8124     SV* new_list;
8125
8126     if (initial_size < 0) {
8127         initial_size = 10;
8128     }
8129
8130     /* Allocate the initial space */
8131     new_list = newSV_type(SVt_INVLIST);
8132
8133     /* First 1 is in case the zero element isn't in the list; second 1 is for
8134      * trailing NUL */
8135     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8136     invlist_set_len(new_list, 0, 0);
8137
8138     /* Force iterinit() to be used to get iteration to work */
8139     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8140
8141     *get_invlist_previous_index_addr(new_list) = 0;
8142
8143     return new_list;
8144 }
8145
8146 SV*
8147 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8148 {
8149     /* Return a pointer to a newly constructed inversion list, initialized to
8150      * point to <list>, which has to be in the exact correct inversion list
8151      * form, including internal fields.  Thus this is a dangerous routine that
8152      * should not be used in the wrong hands.  The passed in 'list' contains
8153      * several header fields at the beginning that are not part of the
8154      * inversion list body proper */
8155
8156     const STRLEN length = (STRLEN) list[0];
8157     const UV version_id =          list[1];
8158     const bool offset   =    cBOOL(list[2]);
8159 #define HEADER_LENGTH 3
8160     /* If any of the above changes in any way, you must change HEADER_LENGTH
8161      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8162      *      perl -E 'say int(rand 2**31-1)'
8163      */
8164 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8165                                         data structure type, so that one being
8166                                         passed in can be validated to be an
8167                                         inversion list of the correct vintage.
8168                                        */
8169
8170     SV* invlist = newSV_type(SVt_INVLIST);
8171
8172     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8173
8174     if (version_id != INVLIST_VERSION_ID) {
8175         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8176     }
8177
8178     /* The generated array passed in includes header elements that aren't part
8179      * of the list proper, so start it just after them */
8180     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8181
8182     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8183                                shouldn't touch it */
8184
8185     *(get_invlist_offset_addr(invlist)) = offset;
8186
8187     /* The 'length' passed to us is the physical number of elements in the
8188      * inversion list.  But if there is an offset the logical number is one
8189      * less than that */
8190     invlist_set_len(invlist, length  - offset, offset);
8191
8192     invlist_set_previous_index(invlist, 0);
8193
8194     /* Initialize the iteration pointer. */
8195     invlist_iterfinish(invlist);
8196
8197     SvREADONLY_on(invlist);
8198
8199     return invlist;
8200 }
8201 #endif /* ifndef PERL_IN_XSUB_RE */
8202
8203 STATIC void
8204 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8205 {
8206     /* Grow the maximum size of an inversion list */
8207
8208     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8209
8210     assert(SvTYPE(invlist) == SVt_INVLIST);
8211
8212     /* Add one to account for the zero element at the beginning which may not
8213      * be counted by the calling parameters */
8214     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8215 }
8216
8217 STATIC void
8218 S__append_range_to_invlist(pTHX_ SV* const invlist,
8219                                  const UV start, const UV end)
8220 {
8221    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8222     * the end of the inversion list.  The range must be above any existing
8223     * ones. */
8224
8225     UV* array;
8226     UV max = invlist_max(invlist);
8227     UV len = _invlist_len(invlist);
8228     bool offset;
8229
8230     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8231
8232     if (len == 0) { /* Empty lists must be initialized */
8233         offset = start != 0;
8234         array = _invlist_array_init(invlist, ! offset);
8235     }
8236     else {
8237         /* Here, the existing list is non-empty. The current max entry in the
8238          * list is generally the first value not in the set, except when the
8239          * set extends to the end of permissible values, in which case it is
8240          * the first entry in that final set, and so this call is an attempt to
8241          * append out-of-order */
8242
8243         UV final_element = len - 1;
8244         array = invlist_array(invlist);
8245         if (array[final_element] > start
8246             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8247         {
8248             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",
8249                      array[final_element], start,
8250                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8251         }
8252
8253         /* Here, it is a legal append.  If the new range begins with the first
8254          * value not in the set, it is extending the set, so the new first
8255          * value not in the set is one greater than the newly extended range.
8256          * */
8257         offset = *get_invlist_offset_addr(invlist);
8258         if (array[final_element] == start) {
8259             if (end != UV_MAX) {
8260                 array[final_element] = end + 1;
8261             }
8262             else {
8263                 /* But if the end is the maximum representable on the machine,
8264                  * just let the range that this would extend to have no end */
8265                 invlist_set_len(invlist, len - 1, offset);
8266             }
8267             return;
8268         }
8269     }
8270
8271     /* Here the new range doesn't extend any existing set.  Add it */
8272
8273     len += 2;   /* Includes an element each for the start and end of range */
8274
8275     /* If wll overflow the existing space, extend, which may cause the array to
8276      * be moved */
8277     if (max < len) {
8278         invlist_extend(invlist, len);
8279
8280         /* Have to set len here to avoid assert failure in invlist_array() */
8281         invlist_set_len(invlist, len, offset);
8282
8283         array = invlist_array(invlist);
8284     }
8285     else {
8286         invlist_set_len(invlist, len, offset);
8287     }
8288
8289     /* The next item on the list starts the range, the one after that is
8290      * one past the new range.  */
8291     array[len - 2] = start;
8292     if (end != UV_MAX) {
8293         array[len - 1] = end + 1;
8294     }
8295     else {
8296         /* But if the end is the maximum representable on the machine, just let
8297          * the range have no end */
8298         invlist_set_len(invlist, len - 1, offset);
8299     }
8300 }
8301
8302 #ifndef PERL_IN_XSUB_RE
8303
8304 IV
8305 Perl__invlist_search(SV* const invlist, const UV cp)
8306 {
8307     /* Searches the inversion list for the entry that contains the input code
8308      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8309      * return value is the index into the list's array of the range that
8310      * contains <cp> */
8311
8312     IV low = 0;
8313     IV mid;
8314     IV high = _invlist_len(invlist);
8315     const IV highest_element = high - 1;
8316     const UV* array;
8317
8318     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8319
8320     /* If list is empty, return failure. */
8321     if (high == 0) {
8322         return -1;
8323     }
8324
8325     /* (We can't get the array unless we know the list is non-empty) */
8326     array = invlist_array(invlist);
8327
8328     mid = invlist_previous_index(invlist);
8329     assert(mid >=0 && mid <= highest_element);
8330
8331     /* <mid> contains the cache of the result of the previous call to this
8332      * function (0 the first time).  See if this call is for the same result,
8333      * or if it is for mid-1.  This is under the theory that calls to this
8334      * function will often be for related code points that are near each other.
8335      * And benchmarks show that caching gives better results.  We also test
8336      * here if the code point is within the bounds of the list.  These tests
8337      * replace others that would have had to be made anyway to make sure that
8338      * the array bounds were not exceeded, and these give us extra information
8339      * at the same time */
8340     if (cp >= array[mid]) {
8341         if (cp >= array[highest_element]) {
8342             return highest_element;
8343         }
8344
8345         /* Here, array[mid] <= cp < array[highest_element].  This means that
8346          * the final element is not the answer, so can exclude it; it also
8347          * means that <mid> is not the final element, so can refer to 'mid + 1'
8348          * safely */
8349         if (cp < array[mid + 1]) {
8350             return mid;
8351         }
8352         high--;
8353         low = mid + 1;
8354     }
8355     else { /* cp < aray[mid] */
8356         if (cp < array[0]) { /* Fail if outside the array */
8357             return -1;
8358         }
8359         high = mid;
8360         if (cp >= array[mid - 1]) {
8361             goto found_entry;
8362         }
8363     }
8364
8365     /* Binary search.  What we are looking for is <i> such that
8366      *  array[i] <= cp < array[i+1]
8367      * The loop below converges on the i+1.  Note that there may not be an
8368      * (i+1)th element in the array, and things work nonetheless */
8369     while (low < high) {
8370         mid = (low + high) / 2;
8371         assert(mid <= highest_element);
8372         if (array[mid] <= cp) { /* cp >= array[mid] */
8373             low = mid + 1;
8374
8375             /* We could do this extra test to exit the loop early.
8376             if (cp < array[low]) {
8377                 return mid;
8378             }
8379             */
8380         }
8381         else { /* cp < array[mid] */
8382             high = mid;
8383         }
8384     }
8385
8386   found_entry:
8387     high--;
8388     invlist_set_previous_index(invlist, high);
8389     return high;
8390 }
8391
8392 void
8393 Perl__invlist_populate_swatch(SV* const invlist,
8394                               const UV start, const UV end, U8* swatch)
8395 {
8396     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8397      * but is used when the swash has an inversion list.  This makes this much
8398      * faster, as it uses a binary search instead of a linear one.  This is
8399      * intimately tied to that function, and perhaps should be in utf8.c,
8400      * except it is intimately tied to inversion lists as well.  It assumes
8401      * that <swatch> is all 0's on input */
8402
8403     UV current = start;
8404     const IV len = _invlist_len(invlist);
8405     IV i;
8406     const UV * array;
8407
8408     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8409
8410     if (len == 0) { /* Empty inversion list */
8411         return;
8412     }
8413
8414     array = invlist_array(invlist);
8415
8416     /* Find which element it is */
8417     i = _invlist_search(invlist, start);
8418
8419     /* We populate from <start> to <end> */
8420     while (current < end) {
8421         UV upper;
8422
8423         /* The inversion list gives the results for every possible code point
8424          * after the first one in the list.  Only those ranges whose index is
8425          * even are ones that the inversion list matches.  For the odd ones,
8426          * and if the initial code point is not in the list, we have to skip
8427          * forward to the next element */
8428         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8429             i++;
8430             if (i >= len) { /* Finished if beyond the end of the array */
8431                 return;
8432             }
8433             current = array[i];
8434             if (current >= end) {   /* Finished if beyond the end of what we
8435                                        are populating */
8436                 if (LIKELY(end < UV_MAX)) {
8437                     return;
8438                 }
8439
8440                 /* We get here when the upper bound is the maximum
8441                  * representable on the machine, and we are looking for just
8442                  * that code point.  Have to special case it */
8443                 i = len;
8444                 goto join_end_of_list;
8445             }
8446         }
8447         assert(current >= start);
8448
8449         /* The current range ends one below the next one, except don't go past
8450          * <end> */
8451         i++;
8452         upper = (i < len && array[i] < end) ? array[i] : end;
8453
8454         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8455          * for each code point in it */
8456         for (; current < upper; current++) {
8457             const STRLEN offset = (STRLEN)(current - start);
8458             swatch[offset >> 3] |= 1 << (offset & 7);
8459         }
8460
8461       join_end_of_list:
8462
8463         /* Quit if at the end of the list */
8464         if (i >= len) {
8465
8466             /* But first, have to deal with the highest possible code point on
8467              * the platform.  The previous code assumes that <end> is one
8468              * beyond where we want to populate, but that is impossible at the
8469              * platform's infinity, so have to handle it specially */
8470             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8471             {
8472                 const STRLEN offset = (STRLEN)(end - start);
8473                 swatch[offset >> 3] |= 1 << (offset & 7);
8474             }
8475             return;
8476         }
8477
8478         /* Advance to the next range, which will be for code points not in the
8479          * inversion list */
8480         current = array[i];
8481     }
8482
8483     return;
8484 }
8485
8486 void
8487 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8488                                          const bool complement_b, SV** output)
8489 {
8490     /* Take the union of two inversion lists and point <output> to it.  *output
8491      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8492      * the reference count to that list will be decremented if not already a
8493      * temporary (mortal); otherwise *output will be made correspondingly
8494      * mortal.  The first list, <a>, may be NULL, in which case a copy of the
8495      * second list is returned.  If <complement_b> is TRUE, the union is taken
8496      * of the complement (inversion) of <b> instead of b itself.
8497      *
8498      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8499      * Richard Gillam, published by Addison-Wesley, and explained at some
8500      * length there.  The preface says to incorporate its examples into your
8501      * code at your own risk.
8502      *
8503      * The algorithm is like a merge sort.
8504      *
8505      * XXX A potential performance improvement is to keep track as we go along
8506      * if only one of the inputs contributes to the result, meaning the other
8507      * is a subset of that one.  In that case, we can skip the final copy and
8508      * return the larger of the input lists, but then outside code might need
8509      * to keep track of whether to free the input list or not */
8510
8511     const UV* array_a;    /* a's array */
8512     const UV* array_b;
8513     UV len_a;       /* length of a's array */
8514     UV len_b;
8515
8516     SV* u;                      /* the resulting union */
8517     UV* array_u;
8518     UV len_u;
8519
8520     UV i_a = 0;             /* current index into a's array */
8521     UV i_b = 0;
8522     UV i_u = 0;
8523
8524     /* running count, as explained in the algorithm source book; items are
8525      * stopped accumulating and are output when the count changes to/from 0.
8526      * The count is incremented when we start a range that's in the set, and
8527      * decremented when we start a range that's not in the set.  So its range
8528      * is 0 to 2.  Only when the count is zero is something not in the set.
8529      */
8530     UV count = 0;
8531
8532     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
8533     assert(a != b);
8534
8535     /* If either one is empty, the union is the other one */
8536     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
8537         bool make_temp = FALSE; /* Should we mortalize the result? */
8538
8539         if (*output == a) {
8540             if (a != NULL) {
8541                 if (! (make_temp = cBOOL(SvTEMP(a)))) {
8542                     SvREFCNT_dec_NN(a);
8543                 }
8544             }
8545         }
8546         if (*output != b) {
8547             *output = invlist_clone(b);
8548             if (complement_b) {
8549                 _invlist_invert(*output);
8550             }
8551         } /* else *output already = b; */
8552
8553         if (make_temp) {
8554             sv_2mortal(*output);
8555         }
8556         return;
8557     }
8558     else if ((len_b = _invlist_len(b)) == 0) {
8559         bool make_temp = FALSE;
8560         if (*output == b) {
8561             if (! (make_temp = cBOOL(SvTEMP(b)))) {
8562                 SvREFCNT_dec_NN(b);
8563             }
8564         }
8565
8566         /* The complement of an empty list is a list that has everything in it,
8567          * so the union with <a> includes everything too */
8568         if (complement_b) {
8569             if (a == *output) {
8570                 if (! (make_temp = cBOOL(SvTEMP(a)))) {
8571                     SvREFCNT_dec_NN(a);
8572                 }
8573             }
8574             *output = _new_invlist(1);
8575             _append_range_to_invlist(*output, 0, UV_MAX);
8576         }
8577         else if (*output != a) {
8578             *output = invlist_clone(a);
8579         }
8580         /* else *output already = a; */
8581
8582         if (make_temp) {
8583             sv_2mortal(*output);
8584         }
8585         return;
8586     }
8587
8588     /* Here both lists exist and are non-empty */
8589     array_a = invlist_array(a);
8590     array_b = invlist_array(b);
8591
8592     /* If are to take the union of 'a' with the complement of b, set it
8593      * up so are looking at b's complement. */
8594     if (complement_b) {
8595
8596         /* To complement, we invert: if the first element is 0, remove it.  To
8597          * do this, we just pretend the array starts one later */
8598         if (array_b[0] == 0) {
8599             array_b++;
8600             len_b--;
8601         }
8602         else {
8603
8604             /* But if the first element is not zero, we pretend the list starts
8605              * at the 0 that is always stored immediately before the array. */
8606             array_b--;
8607             len_b++;
8608         }
8609     }
8610
8611     /* Size the union for the worst case: that the sets are completely
8612      * disjoint */
8613     u = _new_invlist(len_a + len_b);
8614
8615     /* Will contain U+0000 if either component does */
8616     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
8617                                       || (len_b > 0 && array_b[0] == 0));
8618
8619     /* Go through each list item by item, stopping when exhausted one of
8620      * them */
8621     while (i_a < len_a && i_b < len_b) {
8622         UV cp;      /* The element to potentially add to the union's array */
8623         bool cp_in_set;   /* is it in the the input list's set or not */
8624
8625         /* We need to take one or the other of the two inputs for the union.
8626          * Since we are merging two sorted lists, we take the smaller of the
8627          * next items.  In case of a tie, we take the one that is in its set
8628          * first.  If we took one not in the set first, it would decrement the
8629          * count, possibly to 0 which would cause it to be output as ending the
8630          * range, and the next time through we would take the same number, and
8631          * output it again as beginning the next range.  By doing it the
8632          * opposite way, there is no possibility that the count will be
8633          * momentarily decremented to 0, and thus the two adjoining ranges will
8634          * be seamlessly merged.  (In a tie and both are in the set or both not
8635          * in the set, it doesn't matter which we take first.) */
8636         if (array_a[i_a] < array_b[i_b]
8637             || (array_a[i_a] == array_b[i_b]
8638                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
8639         {
8640             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
8641             cp= array_a[i_a++];
8642         }
8643         else {
8644             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
8645             cp = array_b[i_b++];
8646         }
8647
8648         /* Here, have chosen which of the two inputs to look at.  Only output
8649          * if the running count changes to/from 0, which marks the
8650          * beginning/end of a range in that's in the set */
8651         if (cp_in_set) {
8652             if (count == 0) {
8653                 array_u[i_u++] = cp;
8654             }
8655             count++;
8656         }
8657         else {
8658             count--;
8659             if (count == 0) {
8660                 array_u[i_u++] = cp;
8661             }
8662         }
8663     }
8664
8665     /* Here, we are finished going through at least one of the lists, which
8666      * means there is something remaining in at most one.  We check if the list
8667      * that hasn't been exhausted is positioned such that we are in the middle
8668      * of a range in its set or not.  (i_a and i_b point to the element beyond
8669      * the one we care about.) If in the set, we decrement 'count'; if 0, there
8670      * is potentially more to output.
8671      * There are four cases:
8672      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
8673      *     in the union is entirely from the non-exhausted set.
8674      *  2) Both were in their sets, count is 2.  Nothing further should
8675      *     be output, as everything that remains will be in the exhausted
8676      *     list's set, hence in the union; decrementing to 1 but not 0 insures
8677      *     that
8678      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
8679      *     Nothing further should be output because the union includes
8680      *     everything from the exhausted set.  Not decrementing ensures that.
8681      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
8682      *     decrementing to 0 insures that we look at the remainder of the
8683      *     non-exhausted set */
8684     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
8685         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
8686     {
8687         count--;
8688     }
8689
8690     /* The final length is what we've output so far, plus what else is about to
8691      * be output.  (If 'count' is non-zero, then the input list we exhausted
8692      * has everything remaining up to the machine's limit in its set, and hence
8693      * in the union, so there will be no further output. */
8694     len_u = i_u;
8695     if (count == 0) {
8696         /* At most one of the subexpressions will be non-zero */
8697         len_u += (len_a - i_a) + (len_b - i_b);
8698     }
8699
8700     /* Set result to final length, which can change the pointer to array_u, so
8701      * re-find it */
8702     if (len_u != _invlist_len(u)) {
8703         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
8704         invlist_trim(u);
8705         array_u = invlist_array(u);
8706     }
8707
8708     /* When 'count' is 0, the list that was exhausted (if one was shorter than
8709      * the other) ended with everything above it not in its set.  That means
8710      * that the remaining part of the union is precisely the same as the
8711      * non-exhausted list, so can just copy it unchanged.  (If both list were
8712      * exhausted at the same time, then the operations below will be both 0.)
8713      */
8714     if (count == 0) {
8715         IV copy_count; /* At most one will have a non-zero copy count */
8716         if ((copy_count = len_a - i_a) > 0) {
8717             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
8718         }
8719         else if ((copy_count = len_b - i_b) > 0) {
8720             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
8721         }
8722     }
8723
8724     /*  We may be removing a reference to one of the inputs.  If so, the output
8725      *  is made mortal if the input was.  (Mortal SVs shouldn't have their ref
8726      *  count decremented) */
8727     if (a == *output || b == *output) {
8728         assert(! invlist_is_iterating(*output));
8729         if ((SvTEMP(*output))) {
8730             sv_2mortal(u);
8731         }
8732         else {
8733             SvREFCNT_dec_NN(*output);
8734         }
8735     }
8736
8737     *output = u;
8738
8739     return;
8740 }
8741
8742 void
8743 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8744                                                const bool complement_b, SV** i)
8745 {
8746     /* Take the intersection of two inversion lists and point <i> to it.  *i
8747      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8748      * the reference count to that list will be decremented if not already a
8749      * temporary (mortal); otherwise *i will be made correspondingly mortal.
8750      * The first list, <a>, may be NULL, in which case an empty list is
8751      * returned.  If <complement_b> is TRUE, the result will be the
8752      * intersection of <a> and the complement (or inversion) of <b> instead of
8753      * <b> directly.
8754      *
8755      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8756      * Richard Gillam, published by Addison-Wesley, and explained at some
8757      * length there.  The preface says to incorporate its examples into your
8758      * code at your own risk.  In fact, it had bugs
8759      *
8760      * The algorithm is like a merge sort, and is essentially the same as the
8761      * union above
8762      */
8763
8764     const UV* array_a;          /* a's array */
8765     const UV* array_b;
8766     UV len_a;   /* length of a's array */
8767     UV len_b;
8768
8769     SV* r;                   /* the resulting intersection */
8770     UV* array_r;
8771     UV len_r;
8772
8773     UV i_a = 0;             /* current index into a's array */
8774     UV i_b = 0;
8775     UV i_r = 0;
8776
8777     /* running count, as explained in the algorithm source book; items are
8778      * stopped accumulating and are output when the count changes to/from 2.
8779      * The count is incremented when we start a range that's in the set, and
8780      * decremented when we start a range that's not in the set.  So its range
8781      * is 0 to 2.  Only when the count is 2 is something in the intersection.
8782      */
8783     UV count = 0;
8784
8785     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
8786     assert(a != b);
8787
8788     /* Special case if either one is empty */
8789     len_a = (a == NULL) ? 0 : _invlist_len(a);
8790     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
8791         bool make_temp = FALSE;
8792
8793         if (len_a != 0 && complement_b) {
8794
8795             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
8796              * be empty.  Here, also we are using 'b's complement, which hence
8797              * must be every possible code point.  Thus the intersection is
8798              * simply 'a'. */
8799             if (*i != a) {
8800                 if (*i == b) {
8801                     if (! (make_temp = cBOOL(SvTEMP(b)))) {
8802                         SvREFCNT_dec_NN(b);
8803                     }
8804                 }
8805
8806                 *i = invlist_clone(a);
8807             }
8808             /* else *i is already 'a' */
8809
8810             if (make_temp) {
8811                 sv_2mortal(*i);
8812             }
8813             return;
8814         }
8815
8816         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
8817          * intersection must be empty */
8818         if (*i == a) {
8819             if (! (make_temp = cBOOL(SvTEMP(a)))) {
8820                 SvREFCNT_dec_NN(a);
8821             }
8822         }
8823         else if (*i == b) {
8824             if (! (make_temp = cBOOL(SvTEMP(b)))) {
8825                 SvREFCNT_dec_NN(b);
8826             }
8827         }
8828         *i = _new_invlist(0);
8829         if (make_temp) {
8830             sv_2mortal(*i);
8831         }
8832
8833         return;
8834     }
8835
8836     /* Here both lists exist and are non-empty */
8837     array_a = invlist_array(a);
8838     array_b = invlist_array(b);
8839
8840     /* If are to take the intersection of 'a' with the complement of b, set it
8841      * up so are looking at b's complement. */
8842     if (complement_b) {
8843
8844         /* To complement, we invert: if the first element is 0, remove it.  To
8845          * do this, we just pretend the array starts one later */
8846         if (array_b[0] == 0) {
8847             array_b++;
8848             len_b--;
8849         }
8850         else {
8851
8852             /* But if the first element is not zero, we pretend the list starts
8853              * at the 0 that is always stored immediately before the array. */
8854             array_b--;
8855             len_b++;
8856         }
8857     }
8858
8859     /* Size the intersection for the worst case: that the intersection ends up
8860      * fragmenting everything to be completely disjoint */
8861     r= _new_invlist(len_a + len_b);
8862
8863     /* Will contain U+0000 iff both components do */
8864     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
8865                                      && len_b > 0 && array_b[0] == 0);
8866
8867     /* Go through each list item by item, stopping when exhausted one of
8868      * them */
8869     while (i_a < len_a && i_b < len_b) {
8870         UV cp;      /* The element to potentially add to the intersection's
8871                        array */
8872         bool cp_in_set; /* Is it in the input list's set or not */
8873
8874         /* We need to take one or the other of the two inputs for the
8875          * intersection.  Since we are merging two sorted lists, we take the
8876          * smaller of the next items.  In case of a tie, we take the one that
8877          * is not in its set first (a difference from the union algorithm).  If
8878          * we took one in the set first, it would increment the count, possibly
8879          * to 2 which would cause it to be output as starting a range in the
8880          * intersection, and the next time through we would take that same
8881          * number, and output it again as ending the set.  By doing it the
8882          * opposite of this, there is no possibility that the count will be
8883          * momentarily incremented to 2.  (In a tie and both are in the set or
8884          * both not in the set, it doesn't matter which we take first.) */
8885         if (array_a[i_a] < array_b[i_b]
8886             || (array_a[i_a] == array_b[i_b]
8887                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
8888         {
8889             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
8890             cp= array_a[i_a++];
8891         }
8892         else {
8893             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
8894             cp= array_b[i_b++];
8895         }
8896
8897         /* Here, have chosen which of the two inputs to look at.  Only output
8898          * if the running count changes to/from 2, which marks the
8899          * beginning/end of a range that's in the intersection */
8900         if (cp_in_set) {
8901             count++;
8902             if (count == 2) {
8903                 array_r[i_r++] = cp;
8904             }
8905         }
8906         else {
8907             if (count == 2) {
8908                 array_r[i_r++] = cp;
8909             }
8910             count--;
8911         }
8912     }
8913
8914     /* Here, we are finished going through at least one of the lists, which
8915      * means there is something remaining in at most one.  We check if the list
8916      * that has been exhausted is positioned such that we are in the middle
8917      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
8918      * the ones we care about.)  There are four cases:
8919      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
8920      *     nothing left in the intersection.
8921      *  2) Both were in their sets, count is 2 and perhaps is incremented to
8922      *     above 2.  What should be output is exactly that which is in the
8923      *     non-exhausted set, as everything it has is also in the intersection
8924      *     set, and everything it doesn't have can't be in the intersection
8925      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
8926      *     gets incremented to 2.  Like the previous case, the intersection is
8927      *     everything that remains in the non-exhausted set.
8928      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
8929      *     remains 1.  And the intersection has nothing more. */
8930     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
8931         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
8932     {
8933         count++;
8934     }
8935
8936     /* The final length is what we've output so far plus what else is in the
8937      * intersection.  At most one of the subexpressions below will be non-zero
8938      * */
8939     len_r = i_r;
8940     if (count >= 2) {
8941         len_r += (len_a - i_a) + (len_b - i_b);
8942     }
8943
8944     /* Set result to final length, which can change the pointer to array_r, so
8945      * re-find it */
8946     if (len_r != _invlist_len(r)) {
8947         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
8948         invlist_trim(r);
8949         array_r = invlist_array(r);
8950     }
8951
8952     /* Finish outputting any remaining */
8953     if (count >= 2) { /* At most one will have a non-zero copy count */
8954         IV copy_count;
8955         if ((copy_count = len_a - i_a) > 0) {
8956             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
8957         }
8958         else if ((copy_count = len_b - i_b) > 0) {
8959             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
8960         }
8961     }
8962
8963     /*  We may be removing a reference to one of the inputs.  If so, the output
8964      *  is made mortal if the input was.  (Mortal SVs shouldn't have their ref
8965      *  count decremented) */
8966     if (a == *i || b == *i) {
8967         assert(! invlist_is_iterating(*i));
8968         if (SvTEMP(*i)) {
8969             sv_2mortal(r);
8970         }
8971         else {
8972             SvREFCNT_dec_NN(*i);
8973         }
8974     }
8975
8976     *i = r;
8977
8978     return;
8979 }
8980
8981 SV*
8982 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
8983 {
8984     /* Add the range from 'start' to 'end' inclusive to the inversion list's
8985      * set.  A pointer to the inversion list is returned.  This may actually be
8986      * a new list, in which case the passed in one has been destroyed.  The
8987      * passed-in inversion list can be NULL, in which case a new one is created
8988      * with just the one range in it */
8989
8990     SV* range_invlist;
8991     UV len;
8992
8993     if (invlist == NULL) {
8994         invlist = _new_invlist(2);
8995         len = 0;
8996     }
8997     else {
8998         len = _invlist_len(invlist);
8999     }
9000
9001     /* If comes after the final entry actually in the list, can just append it
9002      * to the end, */
9003     if (len == 0
9004         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
9005             && start >= invlist_array(invlist)[len - 1]))
9006     {
9007         _append_range_to_invlist(invlist, start, end);
9008         return invlist;
9009     }
9010
9011     /* Here, can't just append things, create and return a new inversion list
9012      * which is the union of this range and the existing inversion list */
9013     range_invlist = _new_invlist(2);
9014     _append_range_to_invlist(range_invlist, start, end);
9015
9016     _invlist_union(invlist, range_invlist, &invlist);
9017
9018     /* The temporary can be freed */
9019     SvREFCNT_dec_NN(range_invlist);
9020
9021     return invlist;
9022 }
9023
9024 SV*
9025 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9026                                  UV** other_elements_ptr)
9027 {
9028     /* Create and return an inversion list whose contents are to be populated
9029      * by the caller.  The caller gives the number of elements (in 'size') and
9030      * the very first element ('element0').  This function will set
9031      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9032      * are to be placed.
9033      *
9034      * Obviously there is some trust involved that the caller will properly
9035      * fill in the other elements of the array.
9036      *
9037      * (The first element needs to be passed in, as the underlying code does
9038      * things differently depending on whether it is zero or non-zero) */
9039
9040     SV* invlist = _new_invlist(size);
9041     bool offset;
9042
9043     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9044
9045     _append_range_to_invlist(invlist, element0, element0);
9046     offset = *get_invlist_offset_addr(invlist);
9047
9048     invlist_set_len(invlist, size, offset);
9049     *other_elements_ptr = invlist_array(invlist) + 1;
9050     return invlist;
9051 }
9052
9053 #endif
9054
9055 PERL_STATIC_INLINE SV*
9056 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9057     return _add_range_to_invlist(invlist, cp, cp);
9058 }
9059
9060 #ifndef PERL_IN_XSUB_RE
9061 void
9062 Perl__invlist_invert(pTHX_ SV* const invlist)
9063 {
9064     /* Complement the input inversion list.  This adds a 0 if the list didn't
9065      * have a zero; removes it otherwise.  As described above, the data
9066      * structure is set up so that this is very efficient */
9067
9068     PERL_ARGS_ASSERT__INVLIST_INVERT;
9069
9070     assert(! invlist_is_iterating(invlist));
9071
9072     /* The inverse of matching nothing is matching everything */
9073     if (_invlist_len(invlist) == 0) {
9074         _append_range_to_invlist(invlist, 0, UV_MAX);
9075         return;
9076     }
9077
9078     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9079 }
9080
9081 #endif
9082
9083 PERL_STATIC_INLINE SV*
9084 S_invlist_clone(pTHX_ SV* const invlist)
9085 {
9086
9087     /* Return a new inversion list that is a copy of the input one, which is
9088      * unchanged.  The new list will not be mortal even if the old one was. */
9089
9090     /* Need to allocate extra space to accommodate Perl's addition of a
9091      * trailing NUL to SvPV's, since it thinks they are always strings */
9092     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9093     STRLEN physical_length = SvCUR(invlist);
9094     bool offset = *(get_invlist_offset_addr(invlist));
9095
9096     PERL_ARGS_ASSERT_INVLIST_CLONE;
9097
9098     *(get_invlist_offset_addr(new_invlist)) = offset;
9099     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9100     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9101
9102     return new_invlist;
9103 }
9104
9105 PERL_STATIC_INLINE STRLEN*
9106 S_get_invlist_iter_addr(SV* invlist)
9107 {
9108     /* Return the address of the UV that contains the current iteration
9109      * position */
9110
9111     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9112
9113     assert(SvTYPE(invlist) == SVt_INVLIST);
9114
9115     return &(((XINVLIST*) SvANY(invlist))->iterator);
9116 }
9117
9118 PERL_STATIC_INLINE void
9119 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9120 {
9121     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9122
9123     *get_invlist_iter_addr(invlist) = 0;
9124 }
9125
9126 PERL_STATIC_INLINE void
9127 S_invlist_iterfinish(SV* invlist)
9128 {
9129     /* Terminate iterator for invlist.  This is to catch development errors.
9130      * Any iteration that is interrupted before completed should call this
9131      * function.  Functions that add code points anywhere else but to the end
9132      * of an inversion list assert that they are not in the middle of an
9133      * iteration.  If they were, the addition would make the iteration
9134      * problematical: if the iteration hadn't reached the place where things
9135      * were being added, it would be ok */
9136
9137     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9138
9139     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9140 }
9141
9142 STATIC bool
9143 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9144 {
9145     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9146      * This call sets in <*start> and <*end>, the next range in <invlist>.
9147      * Returns <TRUE> if successful and the next call will return the next
9148      * range; <FALSE> if was already at the end of the list.  If the latter,
9149      * <*start> and <*end> are unchanged, and the next call to this function
9150      * will start over at the beginning of the list */
9151
9152     STRLEN* pos = get_invlist_iter_addr(invlist);
9153     UV len = _invlist_len(invlist);
9154     UV *array;
9155
9156     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9157
9158     if (*pos >= len) {
9159         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9160         return FALSE;
9161     }
9162
9163     array = invlist_array(invlist);
9164
9165     *start = array[(*pos)++];
9166
9167     if (*pos >= len) {
9168         *end = UV_MAX;
9169     }
9170     else {
9171         *end = array[(*pos)++] - 1;
9172     }
9173
9174     return TRUE;
9175 }
9176
9177 PERL_STATIC_INLINE UV
9178 S_invlist_highest(SV* const invlist)
9179 {
9180     /* Returns the highest code point that matches an inversion list.  This API
9181      * has an ambiguity, as it returns 0 under either the highest is actually
9182      * 0, or if the list is empty.  If this distinction matters to you, check
9183      * for emptiness before calling this function */
9184
9185     UV len = _invlist_len(invlist);
9186     UV *array;
9187
9188     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9189
9190     if (len == 0) {
9191         return 0;
9192     }
9193
9194     array = invlist_array(invlist);
9195
9196     /* The last element in the array in the inversion list always starts a
9197      * range that goes to infinity.  That range may be for code points that are
9198      * matched in the inversion list, or it may be for ones that aren't
9199      * matched.  In the latter case, the highest code point in the set is one
9200      * less than the beginning of this range; otherwise it is the final element
9201      * of this range: infinity */
9202     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9203            ? UV_MAX
9204            : array[len - 1] - 1;
9205 }
9206
9207 #ifndef PERL_IN_XSUB_RE
9208 SV *
9209 Perl__invlist_contents(pTHX_ SV* const invlist)
9210 {
9211     /* Get the contents of an inversion list into a string SV so that they can
9212      * be printed out.  It uses the format traditionally done for debug tracing
9213      */
9214
9215     UV start, end;
9216     SV* output = newSVpvs("\n");
9217
9218     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
9219
9220     assert(! invlist_is_iterating(invlist));
9221
9222     invlist_iterinit(invlist);
9223     while (invlist_iternext(invlist, &start, &end)) {
9224         if (end == UV_MAX) {
9225             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
9226         }
9227         else if (end != start) {
9228             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
9229                     start,       end);
9230         }
9231         else {
9232             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
9233         }
9234     }
9235
9236     return output;
9237 }
9238 #endif
9239
9240 #ifndef PERL_IN_XSUB_RE
9241 void
9242 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
9243                          const char * const indent, SV* const invlist)
9244 {
9245     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
9246      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
9247      * the string 'indent'.  The output looks like this:
9248          [0] 0x000A .. 0x000D
9249          [2] 0x0085
9250          [4] 0x2028 .. 0x2029
9251          [6] 0x3104 .. INFINITY
9252      * This means that the first range of code points matched by the list are
9253      * 0xA through 0xD; the second range contains only the single code point
9254      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
9255      * are used to define each range (except if the final range extends to
9256      * infinity, only a single element is needed).  The array index of the
9257      * first element for the corresponding range is given in brackets. */
9258
9259     UV start, end;
9260     STRLEN count = 0;
9261
9262     PERL_ARGS_ASSERT__INVLIST_DUMP;
9263
9264     if (invlist_is_iterating(invlist)) {
9265         Perl_dump_indent(aTHX_ level, file,
9266              "%sCan't dump inversion list because is in middle of iterating\n",
9267              indent);
9268         return;
9269     }
9270
9271     invlist_iterinit(invlist);
9272     while (invlist_iternext(invlist, &start, &end)) {
9273         if (end == UV_MAX) {
9274             Perl_dump_indent(aTHX_ level, file,
9275                                        "%s[%"UVuf"] 0x%04"UVXf" .. INFINITY\n",
9276                                    indent, (UV)count, start);
9277         }
9278         else if (end != start) {
9279             Perl_dump_indent(aTHX_ level, file,
9280                                     "%s[%"UVuf"] 0x%04"UVXf" .. 0x%04"UVXf"\n",
9281                                 indent, (UV)count, start,         end);
9282         }
9283         else {
9284             Perl_dump_indent(aTHX_ level, file, "%s[%"UVuf"] 0x%04"UVXf"\n",
9285                                             indent, (UV)count, start);
9286         }
9287         count += 2;
9288     }
9289 }
9290
9291 void
9292 Perl__load_PL_utf8_foldclosures (pTHX)
9293 {
9294     assert(! PL_utf8_foldclosures);
9295
9296     /* If the folds haven't been read in, call a fold function
9297      * to force that */
9298     if (! PL_utf8_tofold) {
9299         U8 dummy[UTF8_MAXBYTES_CASE+1];
9300
9301         /* This string is just a short named one above \xff */
9302         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
9303         assert(PL_utf8_tofold); /* Verify that worked */
9304     }
9305     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
9306 }
9307 #endif
9308
9309 #ifdef PERL_ARGS_ASSERT__INVLISTEQ
9310 bool
9311 S__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
9312 {
9313     /* Return a boolean as to if the two passed in inversion lists are
9314      * identical.  The final argument, if TRUE, says to take the complement of
9315      * the second inversion list before doing the comparison */
9316
9317     const UV* array_a = invlist_array(a);
9318     const UV* array_b = invlist_array(b);
9319     UV len_a = _invlist_len(a);
9320     UV len_b = _invlist_len(b);
9321
9322     UV i = 0;               /* current index into the arrays */
9323     bool retval = TRUE;     /* Assume are identical until proven otherwise */
9324
9325     PERL_ARGS_ASSERT__INVLISTEQ;
9326
9327     /* If are to compare 'a' with the complement of b, set it
9328      * up so are looking at b's complement. */
9329     if (complement_b) {
9330
9331         /* The complement of nothing is everything, so <a> would have to have
9332          * just one element, starting at zero (ending at infinity) */
9333         if (len_b == 0) {
9334             return (len_a == 1 && array_a[0] == 0);
9335         }
9336         else if (array_b[0] == 0) {
9337
9338             /* Otherwise, to complement, we invert.  Here, the first element is
9339              * 0, just remove it.  To do this, we just pretend the array starts
9340              * one later */
9341
9342             array_b++;
9343             len_b--;
9344         }
9345         else {
9346
9347             /* But if the first element is not zero, we pretend the list starts
9348              * at the 0 that is always stored immediately before the array. */
9349             array_b--;
9350             len_b++;
9351         }
9352     }
9353
9354     /* Make sure that the lengths are the same, as well as the final element
9355      * before looping through the remainder.  (Thus we test the length, final,
9356      * and first elements right off the bat) */
9357     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
9358         retval = FALSE;
9359     }
9360     else for (i = 0; i < len_a - 1; i++) {
9361         if (array_a[i] != array_b[i]) {
9362             retval = FALSE;
9363             break;
9364         }
9365     }
9366
9367     return retval;
9368 }
9369 #endif
9370
9371 /*
9372  * As best we can, determine the characters that can match the start of
9373  * the given EXACTF-ish node.
9374  *
9375  * Returns the invlist as a new SV*; it is the caller's responsibility to
9376  * call SvREFCNT_dec() when done with it.
9377  */
9378 STATIC SV*
9379 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
9380 {
9381     const U8 * s = (U8*)STRING(node);
9382     SSize_t bytelen = STR_LEN(node);
9383     UV uc;
9384     /* Start out big enough for 2 separate code points */
9385     SV* invlist = _new_invlist(4);
9386
9387     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
9388
9389     if (! UTF) {
9390         uc = *s;
9391
9392         /* We punt and assume can match anything if the node begins
9393          * with a multi-character fold.  Things are complicated.  For
9394          * example, /ffi/i could match any of:
9395          *  "\N{LATIN SMALL LIGATURE FFI}"
9396          *  "\N{LATIN SMALL LIGATURE FF}I"
9397          *  "F\N{LATIN SMALL LIGATURE FI}"
9398          *  plus several other things; and making sure we have all the
9399          *  possibilities is hard. */
9400         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
9401             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
9402         }
9403         else {
9404             /* Any Latin1 range character can potentially match any
9405              * other depending on the locale */
9406             if (OP(node) == EXACTFL) {
9407                 _invlist_union(invlist, PL_Latin1, &invlist);
9408             }
9409             else {
9410                 /* But otherwise, it matches at least itself.  We can
9411                  * quickly tell if it has a distinct fold, and if so,
9412                  * it matches that as well */
9413                 invlist = add_cp_to_invlist(invlist, uc);
9414                 if (IS_IN_SOME_FOLD_L1(uc))
9415                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
9416             }
9417
9418             /* Some characters match above-Latin1 ones under /i.  This
9419              * is true of EXACTFL ones when the locale is UTF-8 */
9420             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
9421                 && (! isASCII(uc) || (OP(node) != EXACTFA
9422                                     && OP(node) != EXACTFA_NO_TRIE)))
9423             {
9424                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
9425             }
9426         }
9427     }
9428     else {  /* Pattern is UTF-8 */
9429         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
9430         STRLEN foldlen = UTF8SKIP(s);
9431         const U8* e = s + bytelen;
9432         SV** listp;
9433
9434         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
9435
9436         /* The only code points that aren't folded in a UTF EXACTFish
9437          * node are are the problematic ones in EXACTFL nodes */
9438         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
9439             /* We need to check for the possibility that this EXACTFL
9440              * node begins with a multi-char fold.  Therefore we fold
9441              * the first few characters of it so that we can make that
9442              * check */
9443             U8 *d = folded;
9444             int i;
9445
9446             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
9447                 if (isASCII(*s)) {
9448                     *(d++) = (U8) toFOLD(*s);
9449                     s++;
9450                 }
9451                 else {
9452                     STRLEN len;
9453                     to_utf8_fold(s, d, &len);
9454                     d += len;
9455                     s += UTF8SKIP(s);
9456                 }
9457             }
9458
9459             /* And set up so the code below that looks in this folded
9460              * buffer instead of the node's string */
9461             e = d;
9462             foldlen = UTF8SKIP(folded);
9463             s = folded;
9464         }
9465
9466         /* When we reach here 's' points to the fold of the first
9467          * character(s) of the node; and 'e' points to far enough along
9468          * the folded string to be just past any possible multi-char
9469          * fold. 'foldlen' is the length in bytes of the first
9470          * character in 's'
9471          *
9472          * Unlike the non-UTF-8 case, the macro for determining if a
9473          * string is a multi-char fold requires all the characters to
9474          * already be folded.  This is because of all the complications
9475          * if not.  Note that they are folded anyway, except in EXACTFL
9476          * nodes.  Like the non-UTF case above, we punt if the node
9477          * begins with a multi-char fold  */
9478
9479         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
9480             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
9481         }
9482         else {  /* Single char fold */
9483
9484             /* It matches all the things that fold to it, which are
9485              * found in PL_utf8_foldclosures (including itself) */
9486             invlist = add_cp_to_invlist(invlist, uc);
9487             if (! PL_utf8_foldclosures)
9488                 _load_PL_utf8_foldclosures();
9489             if ((listp = hv_fetch(PL_utf8_foldclosures,
9490                                 (char *) s, foldlen, FALSE)))
9491             {
9492                 AV* list = (AV*) *listp;
9493                 IV k;
9494                 for (k = 0; k <= av_tindex(list); k++) {
9495                     SV** c_p = av_fetch(list, k, FALSE);
9496                     UV c;
9497                     assert(c_p);
9498
9499                     c = SvUV(*c_p);
9500
9501                     /* /aa doesn't allow folds between ASCII and non- */
9502                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
9503                         && isASCII(c) != isASCII(uc))
9504                     {
9505                         continue;
9506                     }
9507
9508                     invlist = add_cp_to_invlist(invlist, c);
9509                 }
9510             }
9511         }
9512     }
9513
9514     return invlist;
9515 }
9516
9517 #undef HEADER_LENGTH
9518 #undef TO_INTERNAL_SIZE
9519 #undef FROM_INTERNAL_SIZE
9520 #undef INVLIST_VERSION_ID
9521
9522 /* End of inversion list object */
9523
9524 STATIC void
9525 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
9526 {
9527     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
9528      * constructs, and updates RExC_flags with them.  On input, RExC_parse
9529      * should point to the first flag; it is updated on output to point to the
9530      * final ')' or ':'.  There needs to be at least one flag, or this will
9531      * abort */
9532
9533     /* for (?g), (?gc), and (?o) warnings; warning
9534        about (?c) will warn about (?g) -- japhy    */
9535
9536 #define WASTED_O  0x01
9537 #define WASTED_G  0x02
9538 #define WASTED_C  0x04
9539 #define WASTED_GC (WASTED_G|WASTED_C)
9540     I32 wastedflags = 0x00;
9541     U32 posflags = 0, negflags = 0;
9542     U32 *flagsp = &posflags;
9543     char has_charset_modifier = '\0';
9544     regex_charset cs;
9545     bool has_use_defaults = FALSE;
9546     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
9547     int x_mod_count = 0;
9548
9549     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
9550
9551     /* '^' as an initial flag sets certain defaults */
9552     if (UCHARAT(RExC_parse) == '^') {
9553         RExC_parse++;
9554         has_use_defaults = TRUE;
9555         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
9556         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
9557                                         ? REGEX_UNICODE_CHARSET
9558                                         : REGEX_DEPENDS_CHARSET);
9559     }
9560
9561     cs = get_regex_charset(RExC_flags);
9562     if (cs == REGEX_DEPENDS_CHARSET
9563         && (RExC_utf8 || RExC_uni_semantics))
9564     {
9565         cs = REGEX_UNICODE_CHARSET;
9566     }
9567
9568     while (*RExC_parse) {
9569         /* && strchr("iogcmsx", *RExC_parse) */
9570         /* (?g), (?gc) and (?o) are useless here
9571            and must be globally applied -- japhy */
9572         switch (*RExC_parse) {
9573
9574             /* Code for the imsxn flags */
9575             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
9576
9577             case LOCALE_PAT_MOD:
9578                 if (has_charset_modifier) {
9579                     goto excess_modifier;
9580                 }
9581                 else if (flagsp == &negflags) {
9582                     goto neg_modifier;
9583                 }
9584                 cs = REGEX_LOCALE_CHARSET;
9585                 has_charset_modifier = LOCALE_PAT_MOD;
9586                 break;
9587             case UNICODE_PAT_MOD:
9588                 if (has_charset_modifier) {
9589                     goto excess_modifier;
9590                 }
9591                 else if (flagsp == &negflags) {
9592                     goto neg_modifier;
9593                 }
9594                 cs = REGEX_UNICODE_CHARSET;
9595                 has_charset_modifier = UNICODE_PAT_MOD;
9596                 break;
9597             case ASCII_RESTRICT_PAT_MOD:
9598                 if (flagsp == &negflags) {
9599                     goto neg_modifier;
9600                 }
9601                 if (has_charset_modifier) {
9602                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
9603                         goto excess_modifier;
9604                     }
9605                     /* Doubled modifier implies more restricted */
9606                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
9607                 }
9608                 else {
9609                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
9610                 }
9611                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
9612                 break;
9613             case DEPENDS_PAT_MOD:
9614                 if (has_use_defaults) {
9615                     goto fail_modifiers;
9616                 }
9617                 else if (flagsp == &negflags) {
9618                     goto neg_modifier;
9619                 }
9620                 else if (has_charset_modifier) {
9621                     goto excess_modifier;
9622                 }
9623
9624                 /* The dual charset means unicode semantics if the
9625                  * pattern (or target, not known until runtime) are
9626                  * utf8, or something in the pattern indicates unicode
9627                  * semantics */
9628                 cs = (RExC_utf8 || RExC_uni_semantics)
9629                      ? REGEX_UNICODE_CHARSET
9630                      : REGEX_DEPENDS_CHARSET;
9631                 has_charset_modifier = DEPENDS_PAT_MOD;
9632                 break;
9633               excess_modifier:
9634                 RExC_parse++;
9635                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
9636                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
9637                 }
9638                 else if (has_charset_modifier == *(RExC_parse - 1)) {
9639                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
9640                                         *(RExC_parse - 1));
9641                 }
9642                 else {
9643                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
9644                 }
9645                 NOT_REACHED; /*NOTREACHED*/
9646               neg_modifier:
9647                 RExC_parse++;
9648                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
9649                                     *(RExC_parse - 1));
9650                 NOT_REACHED; /*NOTREACHED*/
9651             case ONCE_PAT_MOD: /* 'o' */
9652             case GLOBAL_PAT_MOD: /* 'g' */
9653                 if (PASS2 && ckWARN(WARN_REGEXP)) {
9654                     const I32 wflagbit = *RExC_parse == 'o'
9655                                          ? WASTED_O
9656                                          : WASTED_G;
9657                     if (! (wastedflags & wflagbit) ) {
9658                         wastedflags |= wflagbit;
9659                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
9660                         vWARN5(
9661                             RExC_parse + 1,
9662                             "Useless (%s%c) - %suse /%c modifier",
9663                             flagsp == &negflags ? "?-" : "?",
9664                             *RExC_parse,
9665                             flagsp == &negflags ? "don't " : "",
9666                             *RExC_parse
9667                         );
9668                     }
9669                 }
9670                 break;
9671
9672             case CONTINUE_PAT_MOD: /* 'c' */
9673                 if (PASS2 && ckWARN(WARN_REGEXP)) {
9674                     if (! (wastedflags & WASTED_C) ) {
9675                         wastedflags |= WASTED_GC;
9676                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
9677                         vWARN3(
9678                             RExC_parse + 1,
9679                             "Useless (%sc) - %suse /gc modifier",
9680                             flagsp == &negflags ? "?-" : "?",
9681                             flagsp == &negflags ? "don't " : ""
9682                         );
9683                     }
9684                 }
9685                 break;
9686             case KEEPCOPY_PAT_MOD: /* 'p' */
9687                 if (flagsp == &negflags) {
9688                     if (PASS2)
9689                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
9690                 } else {
9691                     *flagsp |= RXf_PMf_KEEPCOPY;
9692                 }
9693                 break;
9694             case '-':
9695                 /* A flag is a default iff it is following a minus, so
9696                  * if there is a minus, it means will be trying to
9697                  * re-specify a default which is an error */
9698                 if (has_use_defaults || flagsp == &negflags) {
9699                     goto fail_modifiers;
9700                 }
9701                 flagsp = &negflags;
9702                 wastedflags = 0;  /* reset so (?g-c) warns twice */
9703                 break;
9704             case ':':
9705             case ')':
9706                 RExC_flags |= posflags;
9707                 RExC_flags &= ~negflags;
9708                 set_regex_charset(&RExC_flags, cs);
9709                 if (RExC_flags & RXf_PMf_FOLD) {
9710                     RExC_contains_i = 1;
9711                 }
9712                 if (PASS2) {
9713                     STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9714                 }
9715                 return;
9716                 /*NOTREACHED*/
9717             default:
9718               fail_modifiers:
9719                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
9720                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9721                 vFAIL2utf8f("Sequence (%"UTF8f"...) not recognized",
9722                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
9723                 NOT_REACHED; /*NOTREACHED*/
9724         }
9725
9726         ++RExC_parse;
9727     }
9728
9729     if (PASS2) {
9730         STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9731     }
9732 }
9733
9734 /*
9735  - reg - regular expression, i.e. main body or parenthesized thing
9736  *
9737  * Caller must absorb opening parenthesis.
9738  *
9739  * Combining parenthesis handling with the base level of regular expression
9740  * is a trifle forced, but the need to tie the tails of the branches to what
9741  * follows makes it hard to avoid.
9742  */
9743 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
9744 #ifdef DEBUGGING
9745 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
9746 #else
9747 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
9748 #endif
9749
9750 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
9751    flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
9752    needs to be restarted.
9753    Otherwise would only return NULL if regbranch() returns NULL, which
9754    cannot happen.  */
9755 STATIC regnode *
9756 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
9757     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
9758      * 2 is like 1, but indicates that nextchar() has been called to advance
9759      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
9760      * this flag alerts us to the need to check for that */
9761 {
9762     regnode *ret;               /* Will be the head of the group. */
9763     regnode *br;
9764     regnode *lastbr;
9765     regnode *ender = NULL;
9766     I32 parno = 0;
9767     I32 flags;
9768     U32 oregflags = RExC_flags;
9769     bool have_branch = 0;
9770     bool is_open = 0;
9771     I32 freeze_paren = 0;
9772     I32 after_freeze = 0;
9773     I32 num; /* numeric backreferences */
9774
9775     char * parse_start = RExC_parse; /* MJD */
9776     char * const oregcomp_parse = RExC_parse;
9777
9778     GET_RE_DEBUG_FLAGS_DECL;
9779
9780     PERL_ARGS_ASSERT_REG;
9781     DEBUG_PARSE("reg ");
9782
9783     *flagp = 0;                         /* Tentatively. */
9784
9785
9786     /* Make an OPEN node, if parenthesized. */
9787     if (paren) {
9788
9789         /* Under /x, space and comments can be gobbled up between the '(' and
9790          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
9791          * intervening space, as the sequence is a token, and a token should be
9792          * indivisible */
9793         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
9794
9795         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
9796             char *start_verb = RExC_parse;
9797             STRLEN verb_len = 0;
9798             char *start_arg = NULL;
9799             unsigned char op = 0;
9800             int argok = 1;
9801             int internal_argval = 0; /* internal_argval is only useful if
9802                                         !argok */
9803
9804             if (has_intervening_patws) {
9805                 RExC_parse++;
9806                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
9807             }
9808             while ( *RExC_parse && *RExC_parse != ')' ) {
9809                 if ( *RExC_parse == ':' ) {
9810                     start_arg = RExC_parse + 1;
9811                     break;
9812                 }
9813                 RExC_parse++;
9814             }
9815             ++start_verb;
9816             verb_len = RExC_parse - start_verb;
9817             if ( start_arg ) {
9818                 RExC_parse++;
9819                 while ( *RExC_parse && *RExC_parse != ')' )
9820                     RExC_parse++;
9821                 if ( *RExC_parse != ')' )
9822                     vFAIL("Unterminated verb pattern argument");
9823                 if ( RExC_parse == start_arg )
9824                     start_arg = NULL;
9825             } else {
9826                 if ( *RExC_parse != ')' )
9827                     vFAIL("Unterminated verb pattern");
9828             }
9829
9830             switch ( *start_verb ) {
9831             case 'A':  /* (*ACCEPT) */
9832                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
9833                     op = ACCEPT;
9834                     internal_argval = RExC_nestroot;
9835                 }
9836                 break;
9837             case 'C':  /* (*COMMIT) */
9838                 if ( memEQs(start_verb,verb_len,"COMMIT") )
9839                     op = COMMIT;
9840                 break;
9841             case 'F':  /* (*FAIL) */
9842                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
9843                     op = OPFAIL;
9844                     argok = 0;
9845                 }
9846                 break;
9847             case ':':  /* (*:NAME) */
9848             case 'M':  /* (*MARK:NAME) */
9849                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
9850                     op = MARKPOINT;
9851                     argok = -1;
9852                 }
9853                 break;
9854             case 'P':  /* (*PRUNE) */
9855                 if ( memEQs(start_verb,verb_len,"PRUNE") )
9856                     op = PRUNE;
9857                 break;
9858             case 'S':   /* (*SKIP) */
9859                 if ( memEQs(start_verb,verb_len,"SKIP") )
9860                     op = SKIP;
9861                 break;
9862             case 'T':  /* (*THEN) */
9863                 /* [19:06] <TimToady> :: is then */
9864                 if ( memEQs(start_verb,verb_len,"THEN") ) {
9865                     op = CUTGROUP;
9866                     RExC_seen |= REG_CUTGROUP_SEEN;
9867                 }
9868                 break;
9869             }
9870             if ( ! op ) {
9871                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
9872                 vFAIL2utf8f(
9873                     "Unknown verb pattern '%"UTF8f"'",
9874                     UTF8fARG(UTF, verb_len, start_verb));
9875             }
9876             if ( argok ) {
9877                 if ( start_arg && internal_argval ) {
9878                     vFAIL3("Verb pattern '%.*s' may not have an argument",
9879                         verb_len, start_verb);
9880                 } else if ( argok < 0 && !start_arg ) {
9881                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
9882                         verb_len, start_verb);
9883                 } else {
9884                     ret = reganode(pRExC_state, op, internal_argval);
9885                     if ( ! internal_argval && ! SIZE_ONLY ) {
9886                         if (start_arg) {
9887                             SV *sv = newSVpvn( start_arg,
9888                                                RExC_parse - start_arg);
9889                             ARG(ret) = add_data( pRExC_state,
9890                                                  STR_WITH_LEN("S"));
9891                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
9892                             ret->flags = 0;
9893                         } else {
9894                             ret->flags = 1;
9895                         }
9896                     }
9897                 }
9898                 if (!internal_argval)
9899                     RExC_seen |= REG_VERBARG_SEEN;
9900             } else if ( start_arg ) {
9901                 vFAIL3("Verb pattern '%.*s' may not have an argument",
9902                         verb_len, start_verb);
9903             } else {
9904                 ret = reg_node(pRExC_state, op);
9905             }
9906             nextchar(pRExC_state);
9907             return ret;
9908         }
9909         else if (*RExC_parse == '?') { /* (?...) */
9910             bool is_logical = 0;
9911             const char * const seqstart = RExC_parse;
9912             const char * endptr;
9913             if (has_intervening_patws) {
9914                 RExC_parse++;
9915                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
9916             }
9917
9918             RExC_parse++;
9919             paren = *RExC_parse++;
9920             ret = NULL;                 /* For look-ahead/behind. */
9921             switch (paren) {
9922
9923             case 'P':   /* (?P...) variants for those used to PCRE/Python */
9924                 paren = *RExC_parse++;
9925                 if ( paren == '<')         /* (?P<...>) named capture */
9926                     goto named_capture;
9927                 else if (paren == '>') {   /* (?P>name) named recursion */
9928                     goto named_recursion;
9929                 }
9930                 else if (paren == '=') {   /* (?P=...)  named backref */
9931                     /* this pretty much dupes the code for \k<NAME> in
9932                      * regatom(), if you change this make sure you change that
9933                      * */
9934                     char* name_start = RExC_parse;
9935                     U32 num = 0;
9936                     SV *sv_dat = reg_scan_name(pRExC_state,
9937                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9938                     if (RExC_parse == name_start || *RExC_parse != ')')
9939                         /* diag_listed_as: Sequence ?P=... not terminated in regex; marked by <-- HERE in m/%s/ */
9940                         vFAIL2("Sequence %.3s... not terminated",parse_start);
9941
9942                     if (!SIZE_ONLY) {
9943                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
9944                         RExC_rxi->data->data[num]=(void*)sv_dat;
9945                         SvREFCNT_inc_simple_void(sv_dat);
9946                     }
9947                     RExC_sawback = 1;
9948                     ret = reganode(pRExC_state,
9949                                    ((! FOLD)
9950                                      ? NREF
9951                                      : (ASCII_FOLD_RESTRICTED)
9952                                        ? NREFFA
9953                                        : (AT_LEAST_UNI_SEMANTICS)
9954                                          ? NREFFU
9955                                          : (LOC)
9956                                            ? NREFFL
9957                                            : NREFF),
9958                                     num);
9959                     *flagp |= HASWIDTH;
9960
9961                     Set_Node_Offset(ret, parse_start+1);
9962                     Set_Node_Cur_Length(ret, parse_start);
9963
9964                     nextchar(pRExC_state);
9965                     return ret;
9966                 }
9967                 --RExC_parse;
9968                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
9969                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9970                 vFAIL3("Sequence (%.*s...) not recognized",
9971                                 RExC_parse-seqstart, seqstart);
9972                 NOT_REACHED; /*NOTREACHED*/
9973             case '<':           /* (?<...) */
9974                 if (*RExC_parse == '!')
9975                     paren = ',';
9976                 else if (*RExC_parse != '=')
9977               named_capture:
9978                 {               /* (?<...>) */
9979                     char *name_start;
9980                     SV *svname;
9981                     paren= '>';
9982             case '\'':          /* (?'...') */
9983                     name_start= RExC_parse;
9984                     svname = reg_scan_name(pRExC_state,
9985                         SIZE_ONLY    /* reverse test from the others */
9986                         ? REG_RSN_RETURN_NAME
9987                         : REG_RSN_RETURN_NULL);
9988                     if (RExC_parse == name_start || *RExC_parse != paren)
9989                         vFAIL2("Sequence (?%c... not terminated",
9990                             paren=='>' ? '<' : paren);
9991                     if (SIZE_ONLY) {
9992                         HE *he_str;
9993                         SV *sv_dat = NULL;
9994                         if (!svname) /* shouldn't happen */
9995                             Perl_croak(aTHX_
9996                                 "panic: reg_scan_name returned NULL");
9997                         if (!RExC_paren_names) {
9998                             RExC_paren_names= newHV();
9999                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10000 #ifdef DEBUGGING
10001                             RExC_paren_name_list= newAV();
10002                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10003 #endif
10004                         }
10005                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10006                         if ( he_str )
10007                             sv_dat = HeVAL(he_str);
10008                         if ( ! sv_dat ) {
10009                             /* croak baby croak */
10010                             Perl_croak(aTHX_
10011                                 "panic: paren_name hash element allocation failed");
10012                         } else if ( SvPOK(sv_dat) ) {
10013                             /* (?|...) can mean we have dupes so scan to check
10014                                its already been stored. Maybe a flag indicating
10015                                we are inside such a construct would be useful,
10016                                but the arrays are likely to be quite small, so
10017                                for now we punt -- dmq */
10018                             IV count = SvIV(sv_dat);
10019                             I32 *pv = (I32*)SvPVX(sv_dat);
10020                             IV i;
10021                             for ( i = 0 ; i < count ; i++ ) {
10022                                 if ( pv[i] == RExC_npar ) {
10023                                     count = 0;
10024                                     break;
10025                                 }
10026                             }
10027                             if ( count ) {
10028                                 pv = (I32*)SvGROW(sv_dat,
10029                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10030                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10031                                 pv[count] = RExC_npar;
10032                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10033                             }
10034                         } else {
10035                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10036                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10037                                                                 sizeof(I32));
10038                             SvIOK_on(sv_dat);
10039                             SvIV_set(sv_dat, 1);
10040                         }
10041 #ifdef DEBUGGING
10042                         /* Yes this does cause a memory leak in debugging Perls
10043                          * */
10044                         if (!av_store(RExC_paren_name_list,
10045                                       RExC_npar, SvREFCNT_inc(svname)))
10046                             SvREFCNT_dec_NN(svname);
10047 #endif
10048
10049                         /*sv_dump(sv_dat);*/
10050                     }
10051                     nextchar(pRExC_state);
10052                     paren = 1;
10053                     goto capturing_parens;
10054                 }
10055                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10056                 RExC_in_lookbehind++;
10057                 RExC_parse++;
10058                 /* FALLTHROUGH */
10059             case '=':           /* (?=...) */
10060                 RExC_seen_zerolen++;
10061                 break;
10062             case '!':           /* (?!...) */
10063                 RExC_seen_zerolen++;
10064                 /* check if we're really just a "FAIL" assertion */
10065                 --RExC_parse;
10066                 nextchar(pRExC_state);
10067                 if (*RExC_parse == ')') {
10068                     ret=reg_node(pRExC_state, OPFAIL);
10069                     nextchar(pRExC_state);
10070                     return ret;
10071                 }
10072                 break;
10073             case '|':           /* (?|...) */
10074                 /* branch reset, behave like a (?:...) except that
10075                    buffers in alternations share the same numbers */
10076                 paren = ':';
10077                 after_freeze = freeze_paren = RExC_npar;
10078                 break;
10079             case ':':           /* (?:...) */
10080             case '>':           /* (?>...) */
10081                 break;
10082             case '$':           /* (?$...) */
10083             case '@':           /* (?@...) */
10084                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10085                 break;
10086             case '0' :           /* (?0) */
10087             case 'R' :           /* (?R) */
10088                 if (*RExC_parse != ')')
10089                     FAIL("Sequence (?R) not terminated");
10090                 ret = reg_node(pRExC_state, GOSTART);
10091                     RExC_seen |= REG_GOSTART_SEEN;
10092                 *flagp |= POSTPONED;
10093                 nextchar(pRExC_state);
10094                 return ret;
10095                 /*notreached*/
10096             /* named and numeric backreferences */
10097             case '&':            /* (?&NAME) */
10098                 parse_start = RExC_parse - 1;
10099               named_recursion:
10100                 {
10101                     SV *sv_dat = reg_scan_name(pRExC_state,
10102                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10103                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10104                 }
10105                 if (RExC_parse == RExC_end || *RExC_parse != ')')
10106                     vFAIL("Sequence (?&... not terminated");
10107                 goto gen_recurse_regop;
10108                 /* NOTREACHED */
10109             case '+':
10110                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10111                     RExC_parse++;
10112                     vFAIL("Illegal pattern");
10113                 }
10114                 goto parse_recursion;
10115                 /* NOTREACHED*/
10116             case '-': /* (?-1) */
10117                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10118                     RExC_parse--; /* rewind to let it be handled later */
10119                     goto parse_flags;
10120                 }
10121                 /* FALLTHROUGH */
10122             case '1': case '2': case '3': case '4': /* (?1) */
10123             case '5': case '6': case '7': case '8': case '9':
10124                 RExC_parse--;
10125               parse_recursion:
10126                 {
10127                     bool is_neg = FALSE;
10128                     UV unum;
10129                     parse_start = RExC_parse - 1; /* MJD */
10130                     if (*RExC_parse == '-') {
10131                         RExC_parse++;
10132                         is_neg = TRUE;
10133                     }
10134                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10135                         && unum <= I32_MAX
10136                     ) {
10137                         num = (I32)unum;
10138                         RExC_parse = (char*)endptr;
10139                     } else
10140                         num = I32_MAX;
10141                     if (is_neg) {
10142                         /* Some limit for num? */
10143                         num = -num;
10144                     }
10145                 }
10146                 if (*RExC_parse!=')')
10147                     vFAIL("Expecting close bracket");
10148
10149               gen_recurse_regop:
10150                 if ( paren == '-' ) {
10151                     /*
10152                     Diagram of capture buffer numbering.
10153                     Top line is the normal capture buffer numbers
10154                     Bottom line is the negative indexing as from
10155                     the X (the (?-2))
10156
10157                     +   1 2    3 4 5 X          6 7
10158                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
10159                     -   5 4    3 2 1 X          x x
10160
10161                     */
10162                     num = RExC_npar + num;
10163                     if (num < 1)  {
10164                         RExC_parse++;
10165                         vFAIL("Reference to nonexistent group");
10166                     }
10167                 } else if ( paren == '+' ) {
10168                     num = RExC_npar + num - 1;
10169                 }
10170
10171                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
10172                 if (!SIZE_ONLY) {
10173                     if (num > (I32)RExC_rx->nparens) {
10174                         RExC_parse++;
10175                         vFAIL("Reference to nonexistent group");
10176                     }
10177                     RExC_recurse_count++;
10178                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10179                         "%*s%*s Recurse #%"UVuf" to %"IVdf"\n",
10180                               22, "|    |", (int)(depth * 2 + 1), "",
10181                               (UV)ARG(ret), (IV)ARG2L(ret)));
10182                 }
10183                 RExC_seen |= REG_RECURSE_SEEN;
10184                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
10185                 Set_Node_Offset(ret, parse_start); /* MJD */
10186
10187                 *flagp |= POSTPONED;
10188                 nextchar(pRExC_state);
10189                 return ret;
10190
10191             /* NOTREACHED */
10192
10193             case '?':           /* (??...) */
10194                 is_logical = 1;
10195                 if (*RExC_parse != '{') {
10196                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
10197                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10198                     vFAIL2utf8f(
10199                         "Sequence (%"UTF8f"...) not recognized",
10200                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10201                     NOT_REACHED; /*NOTREACHED*/
10202                 }
10203                 *flagp |= POSTPONED;
10204                 paren = *RExC_parse++;
10205                 /* FALLTHROUGH */
10206             case '{':           /* (?{...}) */
10207             {
10208                 U32 n = 0;
10209                 struct reg_code_block *cb;
10210
10211                 RExC_seen_zerolen++;
10212
10213                 if (   !pRExC_state->num_code_blocks
10214                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
10215                     || pRExC_state->code_blocks[pRExC_state->code_index].start
10216                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
10217                             - RExC_start)
10218                 ) {
10219                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
10220                         FAIL("panic: Sequence (?{...}): no code block found\n");
10221                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
10222                 }
10223                 /* this is a pre-compiled code block (?{...}) */
10224                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
10225                 RExC_parse = RExC_start + cb->end;
10226                 if (!SIZE_ONLY) {
10227                     OP *o = cb->block;
10228                     if (cb->src_regex) {
10229                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
10230                         RExC_rxi->data->data[n] =
10231                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
10232                         RExC_rxi->data->data[n+1] = (void*)o;
10233                     }
10234                     else {
10235                         n = add_data(pRExC_state,
10236                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
10237                         RExC_rxi->data->data[n] = (void*)o;
10238                     }
10239                 }
10240                 pRExC_state->code_index++;
10241                 nextchar(pRExC_state);
10242
10243                 if (is_logical) {
10244                     regnode *eval;
10245                     ret = reg_node(pRExC_state, LOGICAL);
10246
10247                     eval = reg2Lanode(pRExC_state, EVAL,
10248                                        n,
10249
10250                                        /* for later propagation into (??{})
10251                                         * return value */
10252                                        RExC_flags & RXf_PMf_COMPILETIME
10253                                       );
10254                     if (!SIZE_ONLY) {
10255                         ret->flags = 2;
10256                     }
10257                     REGTAIL(pRExC_state, ret, eval);
10258                     /* deal with the length of this later - MJD */
10259                     return ret;
10260                 }
10261                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
10262                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
10263                 Set_Node_Offset(ret, parse_start);
10264                 return ret;
10265             }
10266             case '(':           /* (?(?{...})...) and (?(?=...)...) */
10267             {
10268                 int is_define= 0;
10269                 const int DEFINE_len = sizeof("DEFINE") - 1;
10270                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
10271                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
10272                         || RExC_parse[1] == '<'
10273                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
10274                         I32 flag;
10275                         regnode *tail;
10276
10277                         ret = reg_node(pRExC_state, LOGICAL);
10278                         if (!SIZE_ONLY)
10279                             ret->flags = 1;
10280
10281                         tail = reg(pRExC_state, 1, &flag, depth+1);
10282                         if (flag & RESTART_UTF8) {
10283                             *flagp = RESTART_UTF8;
10284                             return NULL;
10285                         }
10286                         REGTAIL(pRExC_state, ret, tail);
10287                         goto insert_if;
10288                     }
10289                     /* Fall through to ‘Unknown switch condition’ at the
10290                        end of the if/else chain. */
10291                 }
10292                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
10293                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
10294                 {
10295                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
10296                     char *name_start= RExC_parse++;
10297                     U32 num = 0;
10298                     SV *sv_dat=reg_scan_name(pRExC_state,
10299                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10300                     if (RExC_parse == name_start || *RExC_parse != ch)
10301                         vFAIL2("Sequence (?(%c... not terminated",
10302                             (ch == '>' ? '<' : ch));
10303                     RExC_parse++;
10304                     if (!SIZE_ONLY) {
10305                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10306                         RExC_rxi->data->data[num]=(void*)sv_dat;
10307                         SvREFCNT_inc_simple_void(sv_dat);
10308                     }
10309                     ret = reganode(pRExC_state,NGROUPP,num);
10310                     goto insert_if_check_paren;
10311                 }
10312                 else if (RExC_end - RExC_parse >= DEFINE_len
10313                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
10314                 {
10315                     ret = reganode(pRExC_state,DEFINEP,0);
10316                     RExC_parse += DEFINE_len;
10317                     is_define = 1;
10318                     goto insert_if_check_paren;
10319                 }
10320                 else if (RExC_parse[0] == 'R') {
10321                     RExC_parse++;
10322                     parno = 0;
10323                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10324                         UV uv;
10325                         if (grok_atoUV(RExC_parse, &uv, &endptr)
10326                             && uv <= I32_MAX
10327                         ) {
10328                             parno = (I32)uv;
10329                             RExC_parse = (char*)endptr;
10330                         }
10331                         /* else "Switch condition not recognized" below */
10332                     } else if (RExC_parse[0] == '&') {
10333                         SV *sv_dat;
10334                         RExC_parse++;
10335                         sv_dat = reg_scan_name(pRExC_state,
10336                             SIZE_ONLY
10337                             ? REG_RSN_RETURN_NULL
10338                             : REG_RSN_RETURN_DATA);
10339                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10340                     }
10341                     ret = reganode(pRExC_state,INSUBP,parno);
10342                     goto insert_if_check_paren;
10343                 }
10344                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10345                     /* (?(1)...) */
10346                     char c;
10347                     char *tmp;
10348                     UV uv;
10349                     if (grok_atoUV(RExC_parse, &uv, &endptr)
10350                         && uv <= I32_MAX
10351                     ) {
10352                         parno = (I32)uv;
10353                         RExC_parse = (char*)endptr;
10354                     }
10355                     /* XXX else what? */
10356                     ret = reganode(pRExC_state, GROUPP, parno);
10357
10358                  insert_if_check_paren:
10359                     if (*(tmp = nextchar(pRExC_state)) != ')') {
10360                         /* nextchar also skips comments, so undo its work
10361                          * and skip over the the next character.
10362                          */
10363                         RExC_parse = tmp;
10364                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10365                         vFAIL("Switch condition not recognized");
10366                     }
10367                   insert_if:
10368                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
10369                     br = regbranch(pRExC_state, &flags, 1,depth+1);
10370                     if (br == NULL) {
10371                         if (flags & RESTART_UTF8) {
10372                             *flagp = RESTART_UTF8;
10373                             return NULL;
10374                         }
10375                         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10376                               (UV) flags);
10377                     } else
10378                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
10379                                                           LONGJMP, 0));
10380                     c = *nextchar(pRExC_state);
10381                     if (flags&HASWIDTH)
10382                         *flagp |= HASWIDTH;
10383                     if (c == '|') {
10384                         if (is_define)
10385                             vFAIL("(?(DEFINE)....) does not allow branches");
10386
10387                         /* Fake one for optimizer.  */
10388                         lastbr = reganode(pRExC_state, IFTHEN, 0);
10389
10390                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
10391                             if (flags & RESTART_UTF8) {
10392                                 *flagp = RESTART_UTF8;
10393                                 return NULL;
10394                             }
10395                             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10396                                   (UV) flags);
10397                         }
10398                         REGTAIL(pRExC_state, ret, lastbr);
10399                         if (flags&HASWIDTH)
10400                             *flagp |= HASWIDTH;
10401                         c = *nextchar(pRExC_state);
10402                     }
10403                     else
10404                         lastbr = NULL;
10405                     if (c != ')') {
10406                         if (RExC_parse>RExC_end)
10407                             vFAIL("Switch (?(condition)... not terminated");
10408                         else
10409                             vFAIL("Switch (?(condition)... contains too many branches");
10410                     }
10411                     ender = reg_node(pRExC_state, TAIL);
10412                     REGTAIL(pRExC_state, br, ender);
10413                     if (lastbr) {
10414                         REGTAIL(pRExC_state, lastbr, ender);
10415                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
10416                     }
10417                     else
10418                         REGTAIL(pRExC_state, ret, ender);
10419                     RExC_size++; /* XXX WHY do we need this?!!
10420                                     For large programs it seems to be required
10421                                     but I can't figure out why. -- dmq*/
10422                     return ret;
10423                 }
10424                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10425                 vFAIL("Unknown switch condition (?(...))");
10426             }
10427             case '[':           /* (?[ ... ]) */
10428                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
10429                                          oregcomp_parse);
10430             case 0:
10431                 RExC_parse--; /* for vFAIL to print correctly */
10432                 vFAIL("Sequence (? incomplete");
10433                 break;
10434             default: /* e.g., (?i) */
10435                 --RExC_parse;
10436               parse_flags:
10437                 parse_lparen_question_flags(pRExC_state);
10438                 if (UCHARAT(RExC_parse) != ':') {
10439                     if (*RExC_parse)
10440                         nextchar(pRExC_state);
10441                     *flagp = TRYAGAIN;
10442                     return NULL;
10443                 }
10444                 paren = ':';
10445                 nextchar(pRExC_state);
10446                 ret = NULL;
10447                 goto parse_rest;
10448             } /* end switch */
10449         }
10450         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
10451           capturing_parens:
10452             parno = RExC_npar;
10453             RExC_npar++;
10454
10455             ret = reganode(pRExC_state, OPEN, parno);
10456             if (!SIZE_ONLY ){
10457                 if (!RExC_nestroot)
10458                     RExC_nestroot = parno;
10459                 if (RExC_seen & REG_RECURSE_SEEN
10460                     && !RExC_open_parens[parno-1])
10461                 {
10462                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10463                         "%*s%*s Setting open paren #%"IVdf" to %d\n",
10464                         22, "|    |", (int)(depth * 2 + 1), "",
10465                         (IV)parno, REG_NODE_NUM(ret)));
10466                     RExC_open_parens[parno-1]= ret;
10467                 }
10468             }
10469             Set_Node_Length(ret, 1); /* MJD */
10470             Set_Node_Offset(ret, RExC_parse); /* MJD */
10471             is_open = 1;
10472         } else {
10473             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
10474             paren = ':';
10475             ret = NULL;
10476         }
10477     }
10478     else                        /* ! paren */
10479         ret = NULL;
10480
10481    parse_rest:
10482     /* Pick up the branches, linking them together. */
10483     parse_start = RExC_parse;   /* MJD */
10484     br = regbranch(pRExC_state, &flags, 1,depth+1);
10485
10486     /*     branch_len = (paren != 0); */
10487
10488     if (br == NULL) {
10489         if (flags & RESTART_UTF8) {
10490             *flagp = RESTART_UTF8;
10491             return NULL;
10492         }
10493         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
10494     }
10495     if (*RExC_parse == '|') {
10496         if (!SIZE_ONLY && RExC_extralen) {
10497             reginsert(pRExC_state, BRANCHJ, br, depth+1);
10498         }
10499         else {                  /* MJD */
10500             reginsert(pRExC_state, BRANCH, br, depth+1);
10501             Set_Node_Length(br, paren != 0);
10502             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
10503         }
10504         have_branch = 1;
10505         if (SIZE_ONLY)
10506             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
10507     }
10508     else if (paren == ':') {
10509         *flagp |= flags&SIMPLE;
10510     }
10511     if (is_open) {                              /* Starts with OPEN. */
10512         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
10513     }
10514     else if (paren != '?')              /* Not Conditional */
10515         ret = br;
10516     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
10517     lastbr = br;
10518     while (*RExC_parse == '|') {
10519         if (!SIZE_ONLY && RExC_extralen) {
10520             ender = reganode(pRExC_state, LONGJMP,0);
10521
10522             /* Append to the previous. */
10523             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
10524         }
10525         if (SIZE_ONLY)
10526             RExC_extralen += 2;         /* Account for LONGJMP. */
10527         nextchar(pRExC_state);
10528         if (freeze_paren) {
10529             if (RExC_npar > after_freeze)
10530                 after_freeze = RExC_npar;
10531             RExC_npar = freeze_paren;
10532         }
10533         br = regbranch(pRExC_state, &flags, 0, depth+1);
10534
10535         if (br == NULL) {
10536             if (flags & RESTART_UTF8) {
10537                 *flagp = RESTART_UTF8;
10538                 return NULL;
10539             }
10540             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
10541         }
10542         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
10543         lastbr = br;
10544         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
10545     }
10546
10547     if (have_branch || paren != ':') {
10548         /* Make a closing node, and hook it on the end. */
10549         switch (paren) {
10550         case ':':
10551             ender = reg_node(pRExC_state, TAIL);
10552             break;
10553         case 1: case 2:
10554             ender = reganode(pRExC_state, CLOSE, parno);
10555             if (!SIZE_ONLY && RExC_seen & REG_RECURSE_SEEN) {
10556                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10557                         "%*s%*s Setting close paren #%"IVdf" to %d\n",
10558                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
10559                 RExC_close_parens[parno-1]= ender;
10560                 if (RExC_nestroot == parno)
10561                     RExC_nestroot = 0;
10562             }
10563             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
10564             Set_Node_Length(ender,1); /* MJD */
10565             break;
10566         case '<':
10567         case ',':
10568         case '=':
10569         case '!':
10570             *flagp &= ~HASWIDTH;
10571             /* FALLTHROUGH */
10572         case '>':
10573             ender = reg_node(pRExC_state, SUCCEED);
10574             break;
10575         case 0:
10576             ender = reg_node(pRExC_state, END);
10577             if (!SIZE_ONLY) {
10578                 assert(!RExC_opend); /* there can only be one! */
10579                 RExC_opend = ender;
10580             }
10581             break;
10582         }
10583         DEBUG_PARSE_r(if (!SIZE_ONLY) {
10584             DEBUG_PARSE_MSG("lsbr");
10585             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
10586             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
10587             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
10588                           SvPV_nolen_const(RExC_mysv1),
10589                           (IV)REG_NODE_NUM(lastbr),
10590                           SvPV_nolen_const(RExC_mysv2),
10591                           (IV)REG_NODE_NUM(ender),
10592                           (IV)(ender - lastbr)
10593             );
10594         });
10595         REGTAIL(pRExC_state, lastbr, ender);
10596
10597         if (have_branch && !SIZE_ONLY) {
10598             char is_nothing= 1;
10599             if (depth==1)
10600                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
10601
10602             /* Hook the tails of the branches to the closing node. */
10603             for (br = ret; br; br = regnext(br)) {
10604                 const U8 op = PL_regkind[OP(br)];
10605                 if (op == BRANCH) {
10606                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
10607                     if ( OP(NEXTOPER(br)) != NOTHING
10608                          || regnext(NEXTOPER(br)) != ender)
10609                         is_nothing= 0;
10610                 }
10611                 else if (op == BRANCHJ) {
10612                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
10613                     /* for now we always disable this optimisation * /
10614                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
10615                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
10616                     */
10617                         is_nothing= 0;
10618                 }
10619             }
10620             if (is_nothing) {
10621                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
10622                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
10623                     DEBUG_PARSE_MSG("NADA");
10624                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
10625                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
10626                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
10627                                   SvPV_nolen_const(RExC_mysv1),
10628                                   (IV)REG_NODE_NUM(ret),
10629                                   SvPV_nolen_const(RExC_mysv2),
10630                                   (IV)REG_NODE_NUM(ender),
10631                                   (IV)(ender - ret)
10632                     );
10633                 });
10634                 OP(br)= NOTHING;
10635                 if (OP(ender) == TAIL) {
10636                     NEXT_OFF(br)= 0;
10637                     RExC_emit= br + 1;
10638                 } else {
10639                     regnode *opt;
10640                     for ( opt= br + 1; opt < ender ; opt++ )
10641                         OP(opt)= OPTIMIZED;
10642                     NEXT_OFF(br)= ender - br;
10643                 }
10644             }
10645         }
10646     }
10647
10648     {
10649         const char *p;
10650         static const char parens[] = "=!<,>";
10651
10652         if (paren && (p = strchr(parens, paren))) {
10653             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
10654             int flag = (p - parens) > 1;
10655
10656             if (paren == '>')
10657                 node = SUSPEND, flag = 0;
10658             reginsert(pRExC_state, node,ret, depth+1);
10659             Set_Node_Cur_Length(ret, parse_start);
10660             Set_Node_Offset(ret, parse_start + 1);
10661             ret->flags = flag;
10662             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
10663         }
10664     }
10665
10666     /* Check for proper termination. */
10667     if (paren) {
10668         /* restore original flags, but keep (?p) */
10669         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
10670         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
10671             RExC_parse = oregcomp_parse;
10672             vFAIL("Unmatched (");
10673         }
10674     }
10675     else if (!paren && RExC_parse < RExC_end) {
10676         if (*RExC_parse == ')') {
10677             RExC_parse++;
10678             vFAIL("Unmatched )");
10679         }
10680         else
10681             FAIL("Junk on end of regexp");      /* "Can't happen". */
10682         NOT_REACHED; /* NOTREACHED */
10683     }
10684
10685     if (RExC_in_lookbehind) {
10686         RExC_in_lookbehind--;
10687     }
10688     if (after_freeze > RExC_npar)
10689         RExC_npar = after_freeze;
10690     return(ret);
10691 }
10692
10693 /*
10694  - regbranch - one alternative of an | operator
10695  *
10696  * Implements the concatenation operator.
10697  *
10698  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10699  * restarted.
10700  */
10701 STATIC regnode *
10702 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
10703 {
10704     regnode *ret;
10705     regnode *chain = NULL;
10706     regnode *latest;
10707     I32 flags = 0, c = 0;
10708     GET_RE_DEBUG_FLAGS_DECL;
10709
10710     PERL_ARGS_ASSERT_REGBRANCH;
10711
10712     DEBUG_PARSE("brnc");
10713
10714     if (first)
10715         ret = NULL;
10716     else {
10717         if (!SIZE_ONLY && RExC_extralen)
10718             ret = reganode(pRExC_state, BRANCHJ,0);
10719         else {
10720             ret = reg_node(pRExC_state, BRANCH);
10721             Set_Node_Length(ret, 1);
10722         }
10723     }
10724
10725     if (!first && SIZE_ONLY)
10726         RExC_extralen += 1;                     /* BRANCHJ */
10727
10728     *flagp = WORST;                     /* Tentatively. */
10729
10730     RExC_parse--;
10731     nextchar(pRExC_state);
10732     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
10733         flags &= ~TRYAGAIN;
10734         latest = regpiece(pRExC_state, &flags,depth+1);
10735         if (latest == NULL) {
10736             if (flags & TRYAGAIN)
10737                 continue;
10738             if (flags & RESTART_UTF8) {
10739                 *flagp = RESTART_UTF8;
10740                 return NULL;
10741             }
10742             FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags);
10743         }
10744         else if (ret == NULL)
10745             ret = latest;
10746         *flagp |= flags&(HASWIDTH|POSTPONED);
10747         if (chain == NULL)      /* First piece. */
10748             *flagp |= flags&SPSTART;
10749         else {
10750             /* FIXME adding one for every branch after the first is probably
10751              * excessive now we have TRIE support. (hv) */
10752             MARK_NAUGHTY(1);
10753             REGTAIL(pRExC_state, chain, latest);
10754         }
10755         chain = latest;
10756         c++;
10757     }
10758     if (chain == NULL) {        /* Loop ran zero times. */
10759         chain = reg_node(pRExC_state, NOTHING);
10760         if (ret == NULL)
10761             ret = chain;
10762     }
10763     if (c == 1) {
10764         *flagp |= flags&SIMPLE;
10765     }
10766
10767     return ret;
10768 }
10769
10770 /*
10771  - regpiece - something followed by possible [*+?]
10772  *
10773  * Note that the branching code sequences used for ? and the general cases
10774  * of * and + are somewhat optimized:  they use the same NOTHING node as
10775  * both the endmarker for their branch list and the body of the last branch.
10776  * It might seem that this node could be dispensed with entirely, but the
10777  * endmarker role is not redundant.
10778  *
10779  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
10780  * TRYAGAIN.
10781  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10782  * restarted.
10783  */
10784 STATIC regnode *
10785 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10786 {
10787     regnode *ret;
10788     char op;
10789     char *next;
10790     I32 flags;
10791     const char * const origparse = RExC_parse;
10792     I32 min;
10793     I32 max = REG_INFTY;
10794 #ifdef RE_TRACK_PATTERN_OFFSETS
10795     char *parse_start;
10796 #endif
10797     const char *maxpos = NULL;
10798     UV uv;
10799
10800     /* Save the original in case we change the emitted regop to a FAIL. */
10801     regnode * const orig_emit = RExC_emit;
10802
10803     GET_RE_DEBUG_FLAGS_DECL;
10804
10805     PERL_ARGS_ASSERT_REGPIECE;
10806
10807     DEBUG_PARSE("piec");
10808
10809     ret = regatom(pRExC_state, &flags,depth+1);
10810     if (ret == NULL) {
10811         if (flags & (TRYAGAIN|RESTART_UTF8))
10812             *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
10813         else
10814             FAIL2("panic: regatom returned NULL, flags=%#"UVxf"", (UV) flags);
10815         return(NULL);
10816     }
10817
10818     op = *RExC_parse;
10819
10820     if (op == '{' && regcurly(RExC_parse)) {
10821         maxpos = NULL;
10822 #ifdef RE_TRACK_PATTERN_OFFSETS
10823         parse_start = RExC_parse; /* MJD */
10824 #endif
10825         next = RExC_parse + 1;
10826         while (isDIGIT(*next) || *next == ',') {
10827             if (*next == ',') {
10828                 if (maxpos)
10829                     break;
10830                 else
10831                     maxpos = next;
10832             }
10833             next++;
10834         }
10835         if (*next == '}') {             /* got one */
10836             const char* endptr;
10837             if (!maxpos)
10838                 maxpos = next;
10839             RExC_parse++;
10840             if (isDIGIT(*RExC_parse)) {
10841                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
10842                     vFAIL("Invalid quantifier in {,}");
10843                 if (uv >= REG_INFTY)
10844                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
10845                 min = (I32)uv;
10846             } else {
10847                 min = 0;
10848             }
10849             if (*maxpos == ',')
10850                 maxpos++;
10851             else
10852                 maxpos = RExC_parse;
10853             if (isDIGIT(*maxpos)) {
10854                 if (!grok_atoUV(maxpos, &uv, &endptr))
10855                     vFAIL("Invalid quantifier in {,}");
10856                 if (uv >= REG_INFTY)
10857                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
10858                 max = (I32)uv;
10859             } else {
10860                 max = REG_INFTY;                /* meaning "infinity" */
10861             }
10862             RExC_parse = next;
10863             nextchar(pRExC_state);
10864             if (max < min) {    /* If can't match, warn and optimize to fail
10865                                    unconditionally */
10866                 if (SIZE_ONLY) {
10867
10868                     /* We can't back off the size because we have to reserve
10869                      * enough space for all the things we are about to throw
10870                      * away, but we can shrink it by the ammount we are about
10871                      * to re-use here */
10872                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
10873                 }
10874                 else {
10875                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
10876                     RExC_emit = orig_emit;
10877                 }
10878                 ret = reg_node(pRExC_state, OPFAIL);
10879                 return ret;
10880             }
10881             else if (min == max
10882                      && RExC_parse < RExC_end
10883                      && (*RExC_parse == '?' || *RExC_parse == '+'))
10884             {
10885                 if (PASS2) {
10886                     ckWARN2reg(RExC_parse + 1,
10887                                "Useless use of greediness modifier '%c'",
10888                                *RExC_parse);
10889                 }
10890                 /* Absorb the modifier, so later code doesn't see nor use
10891                     * it */
10892                 nextchar(pRExC_state);
10893             }
10894
10895           do_curly:
10896             if ((flags&SIMPLE)) {
10897                 MARK_NAUGHTY_EXP(2, 2);
10898                 reginsert(pRExC_state, CURLY, ret, depth+1);
10899                 Set_Node_Offset(ret, parse_start+1); /* MJD */
10900                 Set_Node_Cur_Length(ret, parse_start);
10901             }
10902             else {
10903                 regnode * const w = reg_node(pRExC_state, WHILEM);
10904
10905                 w->flags = 0;
10906                 REGTAIL(pRExC_state, ret, w);
10907                 if (!SIZE_ONLY && RExC_extralen) {
10908                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
10909                     reginsert(pRExC_state, NOTHING,ret, depth+1);
10910                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
10911                 }
10912                 reginsert(pRExC_state, CURLYX,ret, depth+1);
10913                                 /* MJD hk */
10914                 Set_Node_Offset(ret, parse_start+1);
10915                 Set_Node_Length(ret,
10916                                 op == '{' ? (RExC_parse - parse_start) : 1);
10917
10918                 if (!SIZE_ONLY && RExC_extralen)
10919                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
10920                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
10921                 if (SIZE_ONLY)
10922                     RExC_whilem_seen++, RExC_extralen += 3;
10923                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
10924             }
10925             ret->flags = 0;
10926
10927             if (min > 0)
10928                 *flagp = WORST;
10929             if (max > 0)
10930                 *flagp |= HASWIDTH;
10931             if (!SIZE_ONLY) {
10932                 ARG1_SET(ret, (U16)min);
10933                 ARG2_SET(ret, (U16)max);
10934             }
10935             if (max == REG_INFTY)
10936                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10937
10938             goto nest_check;
10939         }
10940     }
10941
10942     if (!ISMULT1(op)) {
10943         *flagp = flags;
10944         return(ret);
10945     }
10946
10947 #if 0                           /* Now runtime fix should be reliable. */
10948
10949     /* if this is reinstated, don't forget to put this back into perldiag:
10950
10951             =item Regexp *+ operand could be empty at {#} in regex m/%s/
10952
10953            (F) The part of the regexp subject to either the * or + quantifier
10954            could match an empty string. The {#} shows in the regular
10955            expression about where the problem was discovered.
10956
10957     */
10958
10959     if (!(flags&HASWIDTH) && op != '?')
10960       vFAIL("Regexp *+ operand could be empty");
10961 #endif
10962
10963 #ifdef RE_TRACK_PATTERN_OFFSETS
10964     parse_start = RExC_parse;
10965 #endif
10966     nextchar(pRExC_state);
10967
10968     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
10969
10970     if (op == '*' && (flags&SIMPLE)) {
10971         reginsert(pRExC_state, STAR, ret, depth+1);
10972         ret->flags = 0;
10973         MARK_NAUGHTY(4);
10974         RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10975     }
10976     else if (op == '*') {
10977         min = 0;
10978         goto do_curly;
10979     }
10980     else if (op == '+' && (flags&SIMPLE)) {
10981         reginsert(pRExC_state, PLUS, ret, depth+1);
10982         ret->flags = 0;
10983         MARK_NAUGHTY(3);
10984         RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10985     }
10986     else if (op == '+') {
10987         min = 1;
10988         goto do_curly;
10989     }
10990     else if (op == '?') {
10991         min = 0; max = 1;
10992         goto do_curly;
10993     }
10994   nest_check:
10995     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
10996         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
10997         ckWARN2reg(RExC_parse,
10998                    "%"UTF8f" matches null string many times",
10999                    UTF8fARG(UTF, (RExC_parse >= origparse
11000                                  ? RExC_parse - origparse
11001                                  : 0),
11002                    origparse));
11003         (void)ReREFCNT_inc(RExC_rx_sv);
11004     }
11005
11006     if (RExC_parse < RExC_end && *RExC_parse == '?') {
11007         nextchar(pRExC_state);
11008         reginsert(pRExC_state, MINMOD, ret, depth+1);
11009         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11010     }
11011     else
11012     if (RExC_parse < RExC_end && *RExC_parse == '+') {
11013         regnode *ender;
11014         nextchar(pRExC_state);
11015         ender = reg_node(pRExC_state, SUCCEED);
11016         REGTAIL(pRExC_state, ret, ender);
11017         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11018         ret->flags = 0;
11019         ender = reg_node(pRExC_state, TAIL);
11020         REGTAIL(pRExC_state, ret, ender);
11021     }
11022
11023     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
11024         RExC_parse++;
11025         vFAIL("Nested quantifiers");
11026     }
11027
11028     return(ret);
11029 }
11030
11031 STATIC bool
11032 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11033                 regnode ** node_p,
11034                 UV * code_point_p,
11035                 int * cp_count,
11036                 I32 * flagp,
11037                 const U32 depth
11038     )
11039 {
11040  /* This routine teases apart the various meanings of \N and returns
11041   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11042   * in the current context.
11043   *
11044   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11045   *
11046   * If <code_point_p> is not NULL, the context is expecting the result to be a
11047   * single code point.  If this \N instance turns out to a single code point,
11048   * the function returns TRUE and sets *code_point_p to that code point.
11049   *
11050   * If <node_p> is not NULL, the context is expecting the result to be one of
11051   * the things representable by a regnode.  If this \N instance turns out to be
11052   * one such, the function generates the regnode, returns TRUE and sets *node_p
11053   * to point to that regnode.
11054   *
11055   * If this instance of \N isn't legal in any context, this function will
11056   * generate a fatal error and not return.
11057   *
11058   * On input, RExC_parse should point to the first char following the \N at the
11059   * time of the call.  On successful return, RExC_parse will have been updated
11060   * to point to just after the sequence identified by this routine.  Also
11061   * *flagp has been updated as needed.
11062   *
11063   * When there is some problem with the current context and this \N instance,
11064   * the function returns FALSE, without advancing RExC_parse, nor setting
11065   * *node_p, nor *code_point_p, nor *flagp.
11066   *
11067   * If <cp_count> is not NULL, the caller wants to know the length (in code
11068   * points) that this \N sequence matches.  This is set even if the function
11069   * returns FALSE, as detailed below.
11070   *
11071   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11072   *
11073   * Probably the most common case is for the \N to specify a single code point.
11074   * *cp_count will be set to 1, and *code_point_p will be set to that code
11075   * point.
11076   *
11077   * Another possibility is for the input to be an empty \N{}, which for
11078   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11079   * will be set to a generated NOTHING node.
11080   *
11081   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11082   * set to 0. *node_p will be set to a generated REG_ANY node.
11083   *
11084   * The fourth possibility is that \N resolves to a sequence of more than one
11085   * code points.  *cp_count will be set to the number of code points in the
11086   * sequence. *node_p * will be set to a generated node returned by this
11087   * function calling S_reg().
11088   *
11089   * The final possibility, which happens only when the fourth one would
11090   * otherwise be in effect, is that one of those code points requires the
11091   * pattern to be recompiled as UTF-8.  The function returns FALSE, and sets
11092   * the RESTART_UTF8 flag in *flagp.  When this happens, the caller needs to
11093   * desist from continuing parsing, and return this information to its caller.
11094   * This is not set for when there is only one code point, as this can be
11095   * called as part of an ANYOF node, and they can store above-Latin1 code
11096   * points without the pattern having to be in UTF-8.
11097   *
11098   * For non-single-quoted regexes, the tokenizer has resolved character and
11099   * sequence names inside \N{...} into their Unicode values, normalizing the
11100   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11101   * hex-represented code points in the sequence.  This is done there because
11102   * the names can vary based on what charnames pragma is in scope at the time,
11103   * so we need a way to take a snapshot of what they resolve to at the time of
11104   * the original parse. [perl #56444].
11105   *
11106   * That parsing is skipped for single-quoted regexes, so we may here get
11107   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11108   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11109   * is legal and handled here.  The code point is Unicode, and has to be
11110   * translated into the native character set for non-ASCII platforms.
11111   * the tokenizer passes the \N sequence through unchanged; this code will not
11112   * attempt to determine this nor expand those, instead raising a syntax error.
11113   */
11114
11115     char * endbrace;    /* points to '}' following the name */
11116     char *endchar;      /* Points to '.' or '}' ending cur char in the input
11117                            stream */
11118     char* p;            /* Temporary */
11119
11120     GET_RE_DEBUG_FLAGS_DECL;
11121
11122     PERL_ARGS_ASSERT_GROK_BSLASH_N;
11123
11124     GET_RE_DEBUG_FLAGS;
11125
11126     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
11127     assert(! (node_p && cp_count));               /* At most 1 should be set */
11128
11129     if (cp_count) {     /* Initialize return for the most common case */
11130         *cp_count = 1;
11131     }
11132
11133     /* The [^\n] meaning of \N ignores spaces and comments under the /x
11134      * modifier.  The other meanings do not, so use a temporary until we find
11135      * out which we are being called with */
11136     p = (RExC_flags & RXf_PMf_EXTENDED)
11137         ? regpatws(pRExC_state, RExC_parse,
11138                                 TRUE) /* means recognize comments */
11139         : RExC_parse;
11140
11141     /* Disambiguate between \N meaning a named character versus \N meaning
11142      * [^\n].  The latter is assumed when the {...} following the \N is a legal
11143      * quantifier, or there is no a '{' at all */
11144     if (*p != '{' || regcurly(p)) {
11145         RExC_parse = p;
11146         if (cp_count) {
11147             *cp_count = -1;
11148         }
11149
11150         if (! node_p) {
11151             return FALSE;
11152         }
11153         RExC_parse--;   /* Need to back off so nextchar() doesn't skip the
11154                            current char */
11155         nextchar(pRExC_state);
11156         *node_p = reg_node(pRExC_state, REG_ANY);
11157         *flagp |= HASWIDTH|SIMPLE;
11158         MARK_NAUGHTY(1);
11159         Set_Node_Length(*node_p, 1); /* MJD */
11160         return TRUE;
11161     }
11162
11163     /* Here, we have decided it should be a named character or sequence */
11164
11165     /* The test above made sure that the next real character is a '{', but
11166      * under the /x modifier, it could be separated by space (or a comment and
11167      * \n) and this is not allowed (for consistency with \x{...} and the
11168      * tokenizer handling of \N{NAME}). */
11169     if (*RExC_parse != '{') {
11170         vFAIL("Missing braces on \\N{}");
11171     }
11172
11173     RExC_parse++;       /* Skip past the '{' */
11174
11175     if (! (endbrace = strchr(RExC_parse, '}'))  /* no trailing brace */
11176         || ! (endbrace == RExC_parse            /* nothing between the {} */
11177               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
11178                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
11179                                                        error msg) */
11180     {
11181         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
11182         vFAIL("\\N{NAME} must be resolved by the lexer");
11183     }
11184
11185     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
11186
11187     if (endbrace == RExC_parse) {   /* empty: \N{} */
11188         if (cp_count) {
11189             *cp_count = 0;
11190         }
11191         nextchar(pRExC_state);
11192         if (! node_p) {
11193             return FALSE;
11194         }
11195
11196         *node_p = reg_node(pRExC_state,NOTHING);
11197         return TRUE;
11198     }
11199
11200     RExC_parse += 2;    /* Skip past the 'U+' */
11201
11202     endchar = RExC_parse + strcspn(RExC_parse, ".}");
11203
11204     /* Code points are separated by dots.  If none, there is only one code
11205      * point, and is terminated by the brace */
11206
11207     if (endchar >= endbrace) {
11208         STRLEN length_of_hex;
11209         I32 grok_hex_flags;
11210
11211         /* Here, exactly one code point.  If that isn't what is wanted, fail */
11212         if (! code_point_p) {
11213             RExC_parse = p;
11214             return FALSE;
11215         }
11216
11217         /* Convert code point from hex */
11218         length_of_hex = (STRLEN)(endchar - RExC_parse);
11219         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
11220                            | PERL_SCAN_DISALLOW_PREFIX
11221
11222                              /* No errors in the first pass (See [perl
11223                               * #122671].)  We let the code below find the
11224                               * errors when there are multiple chars. */
11225                            | ((SIZE_ONLY)
11226                               ? PERL_SCAN_SILENT_ILLDIGIT
11227                               : 0);
11228
11229         /* This routine is the one place where both single- and double-quotish
11230          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
11231          * must be converted to native. */
11232         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
11233                                          &length_of_hex,
11234                                          &grok_hex_flags,
11235                                          NULL));
11236
11237         /* The tokenizer should have guaranteed validity, but it's possible to
11238          * bypass it by using single quoting, so check.  Don't do the check
11239          * here when there are multiple chars; we do it below anyway. */
11240         if (length_of_hex == 0
11241             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
11242         {
11243             RExC_parse += length_of_hex;        /* Includes all the valid */
11244             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
11245                             ? UTF8SKIP(RExC_parse)
11246                             : 1;
11247             /* Guard against malformed utf8 */
11248             if (RExC_parse >= endchar) {
11249                 RExC_parse = endchar;
11250             }
11251             vFAIL("Invalid hexadecimal number in \\N{U+...}");
11252         }
11253
11254         RExC_parse = endbrace + 1;
11255         return TRUE;
11256     }
11257     else {  /* Is a multiple character sequence */
11258         SV * substitute_parse;
11259         STRLEN len;
11260         char *orig_end = RExC_end;
11261         I32 flags;
11262
11263         /* Count the code points, if desired, in the sequence */
11264         if (cp_count) {
11265             *cp_count = 0;
11266             while (RExC_parse < endbrace) {
11267                 /* Point to the beginning of the next character in the sequence. */
11268                 RExC_parse = endchar + 1;
11269                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
11270                 (*cp_count)++;
11271             }
11272         }
11273
11274         /* Fail if caller doesn't want to handle a multi-code-point sequence.
11275          * But don't backup up the pointer if the caller want to know how many
11276          * code points there are (they can then handle things) */
11277         if (! node_p) {
11278             if (! cp_count) {
11279                 RExC_parse = p;
11280             }
11281             return FALSE;
11282         }
11283
11284         /* What is done here is to convert this to a sub-pattern of the form
11285          * \x{char1}\x{char2}...  and then call reg recursively to parse it
11286          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
11287          * while not having to worry about special handling that some code
11288          * points may have. */
11289
11290         substitute_parse = newSVpvs("?:");
11291
11292         while (RExC_parse < endbrace) {
11293
11294             /* Convert to notation the rest of the code understands */
11295             sv_catpv(substitute_parse, "\\x{");
11296             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
11297             sv_catpv(substitute_parse, "}");
11298
11299             /* Point to the beginning of the next character in the sequence. */
11300             RExC_parse = endchar + 1;
11301             endchar = RExC_parse + strcspn(RExC_parse, ".}");
11302
11303         }
11304         sv_catpv(substitute_parse, ")");
11305
11306         RExC_parse = SvPV(substitute_parse, len);
11307
11308         /* Don't allow empty number */
11309         if (len < (STRLEN) 8) {
11310             RExC_parse = endbrace;
11311             vFAIL("Invalid hexadecimal number in \\N{U+...}");
11312         }
11313         RExC_end = RExC_parse + len;
11314
11315         /* The values are Unicode, and therefore not subject to recoding, but
11316          * have to be converted to native on a non-Unicode (meaning non-ASCII)
11317          * platform. */
11318         RExC_override_recoding = 1;
11319 #ifdef EBCDIC
11320         RExC_recode_x_to_native = 1;
11321 #endif
11322
11323         if (node_p) {
11324             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
11325                 if (flags & RESTART_UTF8) {
11326                     *flagp = RESTART_UTF8;
11327                     return FALSE;
11328                 }
11329                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
11330                     (UV) flags);
11331             }
11332             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
11333         }
11334
11335         /* Restore the saved values */
11336         RExC_parse = endbrace;
11337         RExC_end = orig_end;
11338         RExC_override_recoding = 0;
11339 #ifdef EBCDIC
11340         RExC_recode_x_to_native = 0;
11341 #endif
11342
11343         SvREFCNT_dec_NN(substitute_parse);
11344         nextchar(pRExC_state);
11345
11346         return TRUE;
11347     }
11348 }
11349
11350
11351 /*
11352  * reg_recode
11353  *
11354  * It returns the code point in utf8 for the value in *encp.
11355  *    value: a code value in the source encoding
11356  *    encp:  a pointer to an Encode object
11357  *
11358  * If the result from Encode is not a single character,
11359  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
11360  */
11361 STATIC UV
11362 S_reg_recode(pTHX_ const char value, SV **encp)
11363 {
11364     STRLEN numlen = 1;
11365     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
11366     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
11367     const STRLEN newlen = SvCUR(sv);
11368     UV uv = UNICODE_REPLACEMENT;
11369
11370     PERL_ARGS_ASSERT_REG_RECODE;
11371
11372     if (newlen)
11373         uv = SvUTF8(sv)
11374              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
11375              : *(U8*)s;
11376
11377     if (!newlen || numlen != newlen) {
11378         uv = UNICODE_REPLACEMENT;
11379         *encp = NULL;
11380     }
11381     return uv;
11382 }
11383
11384 PERL_STATIC_INLINE U8
11385 S_compute_EXACTish(RExC_state_t *pRExC_state)
11386 {
11387     U8 op;
11388
11389     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
11390
11391     if (! FOLD) {
11392         return (LOC)
11393                 ? EXACTL
11394                 : EXACT;
11395     }
11396
11397     op = get_regex_charset(RExC_flags);
11398     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
11399         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
11400                  been, so there is no hole */
11401     }
11402
11403     return op + EXACTF;
11404 }
11405
11406 PERL_STATIC_INLINE void
11407 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
11408                          regnode *node, I32* flagp, STRLEN len, UV code_point,
11409                          bool downgradable)
11410 {
11411     /* This knows the details about sizing an EXACTish node, setting flags for
11412      * it (by setting <*flagp>, and potentially populating it with a single
11413      * character.
11414      *
11415      * If <len> (the length in bytes) is non-zero, this function assumes that
11416      * the node has already been populated, and just does the sizing.  In this
11417      * case <code_point> should be the final code point that has already been
11418      * placed into the node.  This value will be ignored except that under some
11419      * circumstances <*flagp> is set based on it.
11420      *
11421      * If <len> is zero, the function assumes that the node is to contain only
11422      * the single character given by <code_point> and calculates what <len>
11423      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
11424      * additionally will populate the node's STRING with <code_point> or its
11425      * fold if folding.
11426      *
11427      * In both cases <*flagp> is appropriately set
11428      *
11429      * It knows that under FOLD, the Latin Sharp S and UTF characters above
11430      * 255, must be folded (the former only when the rules indicate it can
11431      * match 'ss')
11432      *
11433      * When it does the populating, it looks at the flag 'downgradable'.  If
11434      * true with a node that folds, it checks if the single code point
11435      * participates in a fold, and if not downgrades the node to an EXACT.
11436      * This helps the optimizer */
11437
11438     bool len_passed_in = cBOOL(len != 0);
11439     U8 character[UTF8_MAXBYTES_CASE+1];
11440
11441     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
11442
11443     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
11444      * sizing difference, and is extra work that is thrown away */
11445     if (downgradable && ! PASS2) {
11446         downgradable = FALSE;
11447     }
11448
11449     if (! len_passed_in) {
11450         if (UTF) {
11451             if (UVCHR_IS_INVARIANT(code_point)) {
11452                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
11453                     *character = (U8) code_point;
11454                 }
11455                 else { /* Here is /i and not /l. (toFOLD() is defined on just
11456                           ASCII, which isn't the same thing as INVARIANT on
11457                           EBCDIC, but it works there, as the extra invariants
11458                           fold to themselves) */
11459                     *character = toFOLD((U8) code_point);
11460
11461                     /* We can downgrade to an EXACT node if this character
11462                      * isn't a folding one.  Note that this assumes that
11463                      * nothing above Latin1 folds to some other invariant than
11464                      * one of these alphabetics; otherwise we would also have
11465                      * to check:
11466                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
11467                      *      || ASCII_FOLD_RESTRICTED))
11468                      */
11469                     if (downgradable && PL_fold[code_point] == code_point) {
11470                         OP(node) = EXACT;
11471                     }
11472                 }
11473                 len = 1;
11474             }
11475             else if (FOLD && (! LOC
11476                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
11477             {   /* Folding, and ok to do so now */
11478                 UV folded = _to_uni_fold_flags(
11479                                    code_point,
11480                                    character,
11481                                    &len,
11482                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
11483                                                       ? FOLD_FLAGS_NOMIX_ASCII
11484                                                       : 0));
11485                 if (downgradable
11486                     && folded == code_point /* This quickly rules out many
11487                                                cases, avoiding the
11488                                                _invlist_contains_cp() overhead
11489                                                for those.  */
11490                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
11491                 {
11492                     OP(node) = (LOC)
11493                                ? EXACTL
11494                                : EXACT;
11495                 }
11496             }
11497             else if (code_point <= MAX_UTF8_TWO_BYTE) {
11498
11499                 /* Not folding this cp, and can output it directly */
11500                 *character = UTF8_TWO_BYTE_HI(code_point);
11501                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
11502                 len = 2;
11503             }
11504             else {
11505                 uvchr_to_utf8( character, code_point);
11506                 len = UTF8SKIP(character);
11507             }
11508         } /* Else pattern isn't UTF8.  */
11509         else if (! FOLD) {
11510             *character = (U8) code_point;
11511             len = 1;
11512         } /* Else is folded non-UTF8 */
11513         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
11514
11515             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
11516              * comments at join_exact()); */
11517             *character = (U8) code_point;
11518             len = 1;
11519
11520             /* Can turn into an EXACT node if we know the fold at compile time,
11521              * and it folds to itself and doesn't particpate in other folds */
11522             if (downgradable
11523                 && ! LOC
11524                 && PL_fold_latin1[code_point] == code_point
11525                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
11526                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
11527             {
11528                 OP(node) = EXACT;
11529             }
11530         } /* else is Sharp s.  May need to fold it */
11531         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
11532             *character = 's';
11533             *(character + 1) = 's';
11534             len = 2;
11535         }
11536         else {
11537             *character = LATIN_SMALL_LETTER_SHARP_S;
11538             len = 1;
11539         }
11540     }
11541
11542     if (SIZE_ONLY) {
11543         RExC_size += STR_SZ(len);
11544     }
11545     else {
11546         RExC_emit += STR_SZ(len);
11547         STR_LEN(node) = len;
11548         if (! len_passed_in) {
11549             Copy((char *) character, STRING(node), len, char);
11550         }
11551     }
11552
11553     *flagp |= HASWIDTH;
11554
11555     /* A single character node is SIMPLE, except for the special-cased SHARP S
11556      * under /di. */
11557     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
11558         && (code_point != LATIN_SMALL_LETTER_SHARP_S
11559             || ! FOLD || ! DEPENDS_SEMANTICS))
11560     {
11561         *flagp |= SIMPLE;
11562     }
11563
11564     /* The OP may not be well defined in PASS1 */
11565     if (PASS2 && OP(node) == EXACTFL) {
11566         RExC_contains_locale = 1;
11567     }
11568 }
11569
11570
11571 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
11572  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
11573
11574 static I32
11575 S_backref_value(char *p)
11576 {
11577     const char* endptr;
11578     UV val;
11579     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
11580         return (I32)val;
11581     return I32_MAX;
11582 }
11583
11584
11585 /*
11586  - regatom - the lowest level
11587
11588    Try to identify anything special at the start of the pattern. If there
11589    is, then handle it as required. This may involve generating a single regop,
11590    such as for an assertion; or it may involve recursing, such as to
11591    handle a () structure.
11592
11593    If the string doesn't start with something special then we gobble up
11594    as much literal text as we can.
11595
11596    Once we have been able to handle whatever type of thing started the
11597    sequence, we return.
11598
11599    Note: we have to be careful with escapes, as they can be both literal
11600    and special, and in the case of \10 and friends, context determines which.
11601
11602    A summary of the code structure is:
11603
11604    switch (first_byte) {
11605         cases for each special:
11606             handle this special;
11607             break;
11608         case '\\':
11609             switch (2nd byte) {
11610                 cases for each unambiguous special:
11611                     handle this special;
11612                     break;
11613                 cases for each ambigous special/literal:
11614                     disambiguate;
11615                     if (special)  handle here
11616                     else goto defchar;
11617                 default: // unambiguously literal:
11618                     goto defchar;
11619             }
11620         default:  // is a literal char
11621             // FALL THROUGH
11622         defchar:
11623             create EXACTish node for literal;
11624             while (more input and node isn't full) {
11625                 switch (input_byte) {
11626                    cases for each special;
11627                        make sure parse pointer is set so that the next call to
11628                            regatom will see this special first
11629                        goto loopdone; // EXACTish node terminated by prev. char
11630                    default:
11631                        append char to EXACTISH node;
11632                 }
11633                 get next input byte;
11634             }
11635         loopdone:
11636    }
11637    return the generated node;
11638
11639    Specifically there are two separate switches for handling
11640    escape sequences, with the one for handling literal escapes requiring
11641    a dummy entry for all of the special escapes that are actually handled
11642    by the other.
11643
11644    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
11645    TRYAGAIN.
11646    Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
11647    restarted.
11648    Otherwise does not return NULL.
11649 */
11650
11651 STATIC regnode *
11652 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11653 {
11654     regnode *ret = NULL;
11655     I32 flags = 0;
11656     char *parse_start = RExC_parse;
11657     U8 op;
11658     int invert = 0;
11659     U8 arg;
11660
11661     GET_RE_DEBUG_FLAGS_DECL;
11662
11663     *flagp = WORST;             /* Tentatively. */
11664
11665     DEBUG_PARSE("atom");
11666
11667     PERL_ARGS_ASSERT_REGATOM;
11668
11669   tryagain:
11670     switch ((U8)*RExC_parse) {
11671     case '^':
11672         RExC_seen_zerolen++;
11673         nextchar(pRExC_state);
11674         if (RExC_flags & RXf_PMf_MULTILINE)
11675             ret = reg_node(pRExC_state, MBOL);
11676         else
11677             ret = reg_node(pRExC_state, SBOL);
11678         Set_Node_Length(ret, 1); /* MJD */
11679         break;
11680     case '$':
11681         nextchar(pRExC_state);
11682         if (*RExC_parse)
11683             RExC_seen_zerolen++;
11684         if (RExC_flags & RXf_PMf_MULTILINE)
11685             ret = reg_node(pRExC_state, MEOL);
11686         else
11687             ret = reg_node(pRExC_state, SEOL);
11688         Set_Node_Length(ret, 1); /* MJD */
11689         break;
11690     case '.':
11691         nextchar(pRExC_state);
11692         if (RExC_flags & RXf_PMf_SINGLELINE)
11693             ret = reg_node(pRExC_state, SANY);
11694         else
11695             ret = reg_node(pRExC_state, REG_ANY);
11696         *flagp |= HASWIDTH|SIMPLE;
11697         MARK_NAUGHTY(1);
11698         Set_Node_Length(ret, 1); /* MJD */
11699         break;
11700     case '[':
11701     {
11702         char * const oregcomp_parse = ++RExC_parse;
11703         ret = regclass(pRExC_state, flagp,depth+1,
11704                        FALSE, /* means parse the whole char class */
11705                        TRUE, /* allow multi-char folds */
11706                        FALSE, /* don't silence non-portable warnings. */
11707                        (bool) RExC_strict,
11708                        NULL);
11709         if (*RExC_parse != ']') {
11710             RExC_parse = oregcomp_parse;
11711             vFAIL("Unmatched [");
11712         }
11713         if (ret == NULL) {
11714             if (*flagp & RESTART_UTF8)
11715                 return NULL;
11716             FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
11717                   (UV) *flagp);
11718         }
11719         nextchar(pRExC_state);
11720         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
11721         break;
11722     }
11723     case '(':
11724         nextchar(pRExC_state);
11725         ret = reg(pRExC_state, 2, &flags,depth+1);
11726         if (ret == NULL) {
11727                 if (flags & TRYAGAIN) {
11728                     if (RExC_parse == RExC_end) {
11729                          /* Make parent create an empty node if needed. */
11730                         *flagp |= TRYAGAIN;
11731                         return(NULL);
11732                     }
11733                     goto tryagain;
11734                 }
11735                 if (flags & RESTART_UTF8) {
11736                     *flagp = RESTART_UTF8;
11737                     return NULL;
11738                 }
11739                 FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"",
11740                                                                  (UV) flags);
11741         }
11742         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
11743         break;
11744     case '|':
11745     case ')':
11746         if (flags & TRYAGAIN) {
11747             *flagp |= TRYAGAIN;
11748             return NULL;
11749         }
11750         vFAIL("Internal urp");
11751                                 /* Supposed to be caught earlier. */
11752         break;
11753     case '?':
11754     case '+':
11755     case '*':
11756         RExC_parse++;
11757         vFAIL("Quantifier follows nothing");
11758         break;
11759     case '\\':
11760         /* Special Escapes
11761
11762            This switch handles escape sequences that resolve to some kind
11763            of special regop and not to literal text. Escape sequnces that
11764            resolve to literal text are handled below in the switch marked
11765            "Literal Escapes".
11766
11767            Every entry in this switch *must* have a corresponding entry
11768            in the literal escape switch. However, the opposite is not
11769            required, as the default for this switch is to jump to the
11770            literal text handling code.
11771         */
11772         switch ((U8)*++RExC_parse) {
11773         /* Special Escapes */
11774         case 'A':
11775             RExC_seen_zerolen++;
11776             ret = reg_node(pRExC_state, SBOL);
11777             /* SBOL is shared with /^/ so we set the flags so we can tell
11778              * /\A/ from /^/ in split. We check ret because first pass we
11779              * have no regop struct to set the flags on. */
11780             if (PASS2)
11781                 ret->flags = 1;
11782             *flagp |= SIMPLE;
11783             goto finish_meta_pat;
11784         case 'G':
11785             ret = reg_node(pRExC_state, GPOS);
11786             RExC_seen |= REG_GPOS_SEEN;
11787             *flagp |= SIMPLE;
11788             goto finish_meta_pat;
11789         case 'K':
11790             RExC_seen_zerolen++;
11791             ret = reg_node(pRExC_state, KEEPS);
11792             *flagp |= SIMPLE;
11793             /* XXX:dmq : disabling in-place substitution seems to
11794              * be necessary here to avoid cases of memory corruption, as
11795              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
11796              */
11797             RExC_seen |= REG_LOOKBEHIND_SEEN;
11798             goto finish_meta_pat;
11799         case 'Z':
11800             ret = reg_node(pRExC_state, SEOL);
11801             *flagp |= SIMPLE;
11802             RExC_seen_zerolen++;                /* Do not optimize RE away */
11803             goto finish_meta_pat;
11804         case 'z':
11805             ret = reg_node(pRExC_state, EOS);
11806             *flagp |= SIMPLE;
11807             RExC_seen_zerolen++;                /* Do not optimize RE away */
11808             goto finish_meta_pat;
11809         case 'C':
11810             ret = reg_node(pRExC_state, CANY);
11811             RExC_seen |= REG_CANY_SEEN;
11812             *flagp |= HASWIDTH|SIMPLE;
11813             if (PASS2) {
11814                 ckWARNdep(RExC_parse+1, "\\C is deprecated");
11815             }
11816             goto finish_meta_pat;
11817         case 'X':
11818             ret = reg_node(pRExC_state, CLUMP);
11819             *flagp |= HASWIDTH;
11820             goto finish_meta_pat;
11821
11822         case 'W':
11823             invert = 1;
11824             /* FALLTHROUGH */
11825         case 'w':
11826             arg = ANYOF_WORDCHAR;
11827             goto join_posix;
11828
11829         case 'B':
11830             invert = 1;
11831             /* FALLTHROUGH */
11832         case 'b':
11833           {
11834             regex_charset charset = get_regex_charset(RExC_flags);
11835
11836             RExC_seen_zerolen++;
11837             RExC_seen |= REG_LOOKBEHIND_SEEN;
11838             op = BOUND + charset;
11839
11840             if (op == BOUNDL) {
11841                 RExC_contains_locale = 1;
11842             }
11843
11844             ret = reg_node(pRExC_state, op);
11845             *flagp |= SIMPLE;
11846             if (*(RExC_parse + 1) != '{') {
11847                 FLAGS(ret) = TRADITIONAL_BOUND;
11848                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
11849                     OP(ret) = BOUNDA;
11850                 }
11851             }
11852             else {
11853                 STRLEN length;
11854                 char name = *RExC_parse;
11855                 char * endbrace;
11856                 RExC_parse += 2;
11857                 endbrace = strchr(RExC_parse, '}');
11858
11859                 if (! endbrace) {
11860                     vFAIL2("Missing right brace on \\%c{}", name);
11861                 }
11862                 /* XXX Need to decide whether to take spaces or not.  Should be
11863                  * consistent with \p{}, but that currently is SPACE, which
11864                  * means vertical too, which seems wrong
11865                  * while (isBLANK(*RExC_parse)) {
11866                     RExC_parse++;
11867                 }*/
11868                 if (endbrace == RExC_parse) {
11869                     RExC_parse++;  /* After the '}' */
11870                     vFAIL2("Empty \\%c{}", name);
11871                 }
11872                 length = endbrace - RExC_parse;
11873                 /*while (isBLANK(*(RExC_parse + length - 1))) {
11874                     length--;
11875                 }*/
11876                 switch (*RExC_parse) {
11877                     case 'g':
11878                         if (length != 1
11879                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
11880                         {
11881                             goto bad_bound_type;
11882                         }
11883                         FLAGS(ret) = GCB_BOUND;
11884                         break;
11885                     case 's':
11886                         if (length != 2 || *(RExC_parse + 1) != 'b') {
11887                             goto bad_bound_type;
11888                         }
11889                         FLAGS(ret) = SB_BOUND;
11890                         break;
11891                     case 'w':
11892                         if (length != 2 || *(RExC_parse + 1) != 'b') {
11893                             goto bad_bound_type;
11894                         }
11895                         FLAGS(ret) = WB_BOUND;
11896                         break;
11897                     default:
11898                       bad_bound_type:
11899                         RExC_parse = endbrace;
11900                         vFAIL2utf8f(
11901                             "'%"UTF8f"' is an unknown bound type",
11902                             UTF8fARG(UTF, length, endbrace - length));
11903                         NOT_REACHED; /*NOTREACHED*/
11904                 }
11905                 RExC_parse = endbrace;
11906                 RExC_uni_semantics = 1;
11907
11908                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
11909                     OP(ret) = BOUNDU;
11910                     length += 4;
11911
11912                     /* Don't have to worry about UTF-8, in this message because
11913                      * to get here the contents of the \b must be ASCII */
11914                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
11915                               "Using /u for '%.*s' instead of /%s",
11916                               (unsigned) length,
11917                               endbrace - length + 1,
11918                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
11919                               ? ASCII_RESTRICT_PAT_MODS
11920                               : ASCII_MORE_RESTRICT_PAT_MODS);
11921                 }
11922             }
11923
11924             if (PASS2 && invert) {
11925                 OP(ret) += NBOUND - BOUND;
11926             }
11927             goto finish_meta_pat;
11928           }
11929
11930         case 'D':
11931             invert = 1;
11932             /* FALLTHROUGH */
11933         case 'd':
11934             arg = ANYOF_DIGIT;
11935             if (! DEPENDS_SEMANTICS) {
11936                 goto join_posix;
11937             }
11938
11939             /* \d doesn't have any matches in the upper Latin1 range, hence /d
11940              * is equivalent to /u.  Changing to /u saves some branches at
11941              * runtime */
11942             op = POSIXU;
11943             goto join_posix_op_known;
11944
11945         case 'R':
11946             ret = reg_node(pRExC_state, LNBREAK);
11947             *flagp |= HASWIDTH|SIMPLE;
11948             goto finish_meta_pat;
11949
11950         case 'H':
11951             invert = 1;
11952             /* FALLTHROUGH */
11953         case 'h':
11954             arg = ANYOF_BLANK;
11955             op = POSIXU;
11956             goto join_posix_op_known;
11957
11958         case 'V':
11959             invert = 1;
11960             /* FALLTHROUGH */
11961         case 'v':
11962             arg = ANYOF_VERTWS;
11963             op = POSIXU;
11964             goto join_posix_op_known;
11965
11966         case 'S':
11967             invert = 1;
11968             /* FALLTHROUGH */
11969         case 's':
11970             arg = ANYOF_SPACE;
11971
11972           join_posix:
11973
11974             op = POSIXD + get_regex_charset(RExC_flags);
11975             if (op > POSIXA) {  /* /aa is same as /a */
11976                 op = POSIXA;
11977             }
11978             else if (op == POSIXL) {
11979                 RExC_contains_locale = 1;
11980             }
11981
11982           join_posix_op_known:
11983
11984             if (invert) {
11985                 op += NPOSIXD - POSIXD;
11986             }
11987
11988             ret = reg_node(pRExC_state, op);
11989             if (! SIZE_ONLY) {
11990                 FLAGS(ret) = namedclass_to_classnum(arg);
11991             }
11992
11993             *flagp |= HASWIDTH|SIMPLE;
11994             /* FALLTHROUGH */
11995
11996           finish_meta_pat:
11997             nextchar(pRExC_state);
11998             Set_Node_Length(ret, 2); /* MJD */
11999             break;
12000         case 'p':
12001         case 'P':
12002             {
12003 #ifdef DEBUGGING
12004                 char* parse_start = RExC_parse - 2;
12005 #endif
12006
12007                 RExC_parse--;
12008
12009                 ret = regclass(pRExC_state, flagp,depth+1,
12010                                TRUE, /* means just parse this element */
12011                                FALSE, /* don't allow multi-char folds */
12012                                FALSE, /* don't silence non-portable warnings.
12013                                          It would be a bug if these returned
12014                                          non-portables */
12015                                (bool) RExC_strict,
12016                                NULL);
12017                 /* regclass() can only return RESTART_UTF8 if multi-char folds
12018                    are allowed.  */
12019                 if (!ret)
12020                     FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
12021                           (UV) *flagp);
12022
12023                 RExC_parse--;
12024
12025                 Set_Node_Offset(ret, parse_start + 2);
12026                 Set_Node_Cur_Length(ret, parse_start);
12027                 nextchar(pRExC_state);
12028             }
12029             break;
12030         case 'N':
12031             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12032              * \N{...} evaluates to a sequence of more than one code points).
12033              * The function call below returns a regnode, which is our result.
12034              * The parameters cause it to fail if the \N{} evaluates to a
12035              * single code point; we handle those like any other literal.  The
12036              * reason that the multicharacter case is handled here and not as
12037              * part of the EXACtish code is because of quantifiers.  In
12038              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12039              * this way makes that Just Happen. dmq.
12040              * join_exact() will join this up with adjacent EXACTish nodes
12041              * later on, if appropriate. */
12042             ++RExC_parse;
12043             if (grok_bslash_N(pRExC_state,
12044                               &ret,     /* Want a regnode returned */
12045                               NULL,     /* Fail if evaluates to a single code
12046                                            point */
12047                               NULL,     /* Don't need a count of how many code
12048                                            points */
12049                               flagp,
12050                               depth)
12051             ) {
12052                 break;
12053             }
12054
12055             if (*flagp & RESTART_UTF8)
12056                 return NULL;
12057             RExC_parse--;
12058             goto defchar;
12059
12060         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12061       parse_named_seq:
12062         {
12063             char ch= RExC_parse[1];
12064             if (ch != '<' && ch != '\'' && ch != '{') {
12065                 RExC_parse++;
12066                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12067                 vFAIL2("Sequence %.2s... not terminated",parse_start);
12068             } else {
12069                 /* this pretty much dupes the code for (?P=...) in reg(), if
12070                    you change this make sure you change that */
12071                 char* name_start = (RExC_parse += 2);
12072                 U32 num = 0;
12073                 SV *sv_dat = reg_scan_name(pRExC_state,
12074                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
12075                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
12076                 if (RExC_parse == name_start || *RExC_parse != ch)
12077                     /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12078                     vFAIL2("Sequence %.3s... not terminated",parse_start);
12079
12080                 if (!SIZE_ONLY) {
12081                     num = add_data( pRExC_state, STR_WITH_LEN("S"));
12082                     RExC_rxi->data->data[num]=(void*)sv_dat;
12083                     SvREFCNT_inc_simple_void(sv_dat);
12084                 }
12085
12086                 RExC_sawback = 1;
12087                 ret = reganode(pRExC_state,
12088                                ((! FOLD)
12089                                  ? NREF
12090                                  : (ASCII_FOLD_RESTRICTED)
12091                                    ? NREFFA
12092                                    : (AT_LEAST_UNI_SEMANTICS)
12093                                      ? NREFFU
12094                                      : (LOC)
12095                                        ? NREFFL
12096                                        : NREFF),
12097                                 num);
12098                 *flagp |= HASWIDTH;
12099
12100                 /* override incorrect value set in reganode MJD */
12101                 Set_Node_Offset(ret, parse_start+1);
12102                 Set_Node_Cur_Length(ret, parse_start);
12103                 nextchar(pRExC_state);
12104
12105             }
12106             break;
12107         }
12108         case 'g':
12109         case '1': case '2': case '3': case '4':
12110         case '5': case '6': case '7': case '8': case '9':
12111             {
12112                 I32 num;
12113                 bool hasbrace = 0;
12114
12115                 if (*RExC_parse == 'g') {
12116                     bool isrel = 0;
12117
12118                     RExC_parse++;
12119                     if (*RExC_parse == '{') {
12120                         RExC_parse++;
12121                         hasbrace = 1;
12122                     }
12123                     if (*RExC_parse == '-') {
12124                         RExC_parse++;
12125                         isrel = 1;
12126                     }
12127                     if (hasbrace && !isDIGIT(*RExC_parse)) {
12128                         if (isrel) RExC_parse--;
12129                         RExC_parse -= 2;
12130                         goto parse_named_seq;
12131                     }
12132
12133                     num = S_backref_value(RExC_parse);
12134                     if (num == 0)
12135                         vFAIL("Reference to invalid group 0");
12136                     else if (num == I32_MAX) {
12137                          if (isDIGIT(*RExC_parse))
12138                             vFAIL("Reference to nonexistent group");
12139                         else
12140                             vFAIL("Unterminated \\g... pattern");
12141                     }
12142
12143                     if (isrel) {
12144                         num = RExC_npar - num;
12145                         if (num < 1)
12146                             vFAIL("Reference to nonexistent or unclosed group");
12147                     }
12148                 }
12149                 else {
12150                     num = S_backref_value(RExC_parse);
12151                     /* bare \NNN might be backref or octal - if it is larger
12152                      * than or equal RExC_npar then it is assumed to be an
12153                      * octal escape. Note RExC_npar is +1 from the actual
12154                      * number of parens. */
12155                     /* Note we do NOT check if num == I32_MAX here, as that is
12156                      * handled by the RExC_npar check */
12157
12158                     if (
12159                         /* any numeric escape < 10 is always a backref */
12160                         num > 9
12161                         /* any numeric escape < RExC_npar is a backref */
12162                         && num >= RExC_npar
12163                         /* cannot be an octal escape if it starts with 8 */
12164                         && *RExC_parse != '8'
12165                         /* cannot be an octal escape it it starts with 9 */
12166                         && *RExC_parse != '9'
12167                     )
12168                     {
12169                         /* Probably not a backref, instead likely to be an
12170                          * octal character escape, e.g. \35 or \777.
12171                          * The above logic should make it obvious why using
12172                          * octal escapes in patterns is problematic. - Yves */
12173                         goto defchar;
12174                     }
12175                 }
12176
12177                 /* At this point RExC_parse points at a numeric escape like
12178                  * \12 or \88 or something similar, which we should NOT treat
12179                  * as an octal escape. It may or may not be a valid backref
12180                  * escape. For instance \88888888 is unlikely to be a valid
12181                  * backref. */
12182                 {
12183 #ifdef RE_TRACK_PATTERN_OFFSETS
12184                     char * const parse_start = RExC_parse - 1; /* MJD */
12185 #endif
12186                     while (isDIGIT(*RExC_parse))
12187                         RExC_parse++;
12188                     if (hasbrace) {
12189                         if (*RExC_parse != '}')
12190                             vFAIL("Unterminated \\g{...} pattern");
12191                         RExC_parse++;
12192                     }
12193                     if (!SIZE_ONLY) {
12194                         if (num > (I32)RExC_rx->nparens)
12195                             vFAIL("Reference to nonexistent group");
12196                     }
12197                     RExC_sawback = 1;
12198                     ret = reganode(pRExC_state,
12199                                    ((! FOLD)
12200                                      ? REF
12201                                      : (ASCII_FOLD_RESTRICTED)
12202                                        ? REFFA
12203                                        : (AT_LEAST_UNI_SEMANTICS)
12204                                          ? REFFU
12205                                          : (LOC)
12206                                            ? REFFL
12207                                            : REFF),
12208                                     num);
12209                     *flagp |= HASWIDTH;
12210
12211                     /* override incorrect value set in reganode MJD */
12212                     Set_Node_Offset(ret, parse_start+1);
12213                     Set_Node_Cur_Length(ret, parse_start);
12214                     RExC_parse--;
12215                     nextchar(pRExC_state);
12216                 }
12217             }
12218             break;
12219         case '\0':
12220             if (RExC_parse >= RExC_end)
12221                 FAIL("Trailing \\");
12222             /* FALLTHROUGH */
12223         default:
12224             /* Do not generate "unrecognized" warnings here, we fall
12225                back into the quick-grab loop below */
12226             parse_start--;
12227             goto defchar;
12228         }
12229         break;
12230
12231     case '#':
12232         if (RExC_flags & RXf_PMf_EXTENDED) {
12233             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
12234             if (RExC_parse < RExC_end)
12235                 goto tryagain;
12236         }
12237         /* FALLTHROUGH */
12238
12239     default:
12240
12241             parse_start = RExC_parse - 1;
12242
12243             RExC_parse++;
12244
12245           defchar: {
12246             STRLEN len = 0;
12247             UV ender = 0;
12248             char *p;
12249             char *s;
12250 #define MAX_NODE_STRING_SIZE 127
12251             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
12252             char *s0;
12253             U8 upper_parse = MAX_NODE_STRING_SIZE;
12254             U8 node_type = compute_EXACTish(pRExC_state);
12255             bool next_is_quantifier;
12256             char * oldp = NULL;
12257
12258             /* We can convert EXACTF nodes to EXACTFU if they contain only
12259              * characters that match identically regardless of the target
12260              * string's UTF8ness.  The reason to do this is that EXACTF is not
12261              * trie-able, EXACTFU is.
12262              *
12263              * Similarly, we can convert EXACTFL nodes to EXACTFU if they
12264              * contain only above-Latin1 characters (hence must be in UTF8),
12265              * which don't participate in folds with Latin1-range characters,
12266              * as the latter's folds aren't known until runtime.  (We don't
12267              * need to figure this out until pass 2) */
12268             bool maybe_exactfu = PASS2
12269                                && (node_type == EXACTF || node_type == EXACTFL);
12270
12271             /* If a folding node contains only code points that don't
12272              * participate in folds, it can be changed into an EXACT node,
12273              * which allows the optimizer more things to look for */
12274             bool maybe_exact;
12275
12276             ret = reg_node(pRExC_state, node_type);
12277
12278             /* In pass1, folded, we use a temporary buffer instead of the
12279              * actual node, as the node doesn't exist yet */
12280             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
12281
12282             s0 = s;
12283
12284           reparse:
12285
12286             /* We do the EXACTFish to EXACT node only if folding.  (And we
12287              * don't need to figure this out until pass 2) */
12288             maybe_exact = FOLD && PASS2;
12289
12290             /* XXX The node can hold up to 255 bytes, yet this only goes to
12291              * 127.  I (khw) do not know why.  Keeping it somewhat less than
12292              * 255 allows us to not have to worry about overflow due to
12293              * converting to utf8 and fold expansion, but that value is
12294              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
12295              * split up by this limit into a single one using the real max of
12296              * 255.  Even at 127, this breaks under rare circumstances.  If
12297              * folding, we do not want to split a node at a character that is a
12298              * non-final in a multi-char fold, as an input string could just
12299              * happen to want to match across the node boundary.  The join
12300              * would solve that problem if the join actually happens.  But a
12301              * series of more than two nodes in a row each of 127 would cause
12302              * the first join to succeed to get to 254, but then there wouldn't
12303              * be room for the next one, which could at be one of those split
12304              * multi-char folds.  I don't know of any fool-proof solution.  One
12305              * could back off to end with only a code point that isn't such a
12306              * non-final, but it is possible for there not to be any in the
12307              * entire node. */
12308             for (p = RExC_parse - 1;
12309                  len < upper_parse && p < RExC_end;
12310                  len++)
12311             {
12312                 oldp = p;
12313
12314                 if (RExC_flags & RXf_PMf_EXTENDED)
12315                     p = regpatws(pRExC_state, p,
12316                                           TRUE); /* means recognize comments */
12317                 switch ((U8)*p) {
12318                 case '^':
12319                 case '$':
12320                 case '.':
12321                 case '[':
12322                 case '(':
12323                 case ')':
12324                 case '|':
12325                     goto loopdone;
12326                 case '\\':
12327                     /* Literal Escapes Switch
12328
12329                        This switch is meant to handle escape sequences that
12330                        resolve to a literal character.
12331
12332                        Every escape sequence that represents something
12333                        else, like an assertion or a char class, is handled
12334                        in the switch marked 'Special Escapes' above in this
12335                        routine, but also has an entry here as anything that
12336                        isn't explicitly mentioned here will be treated as
12337                        an unescaped equivalent literal.
12338                     */
12339
12340                     switch ((U8)*++p) {
12341                     /* These are all the special escapes. */
12342                     case 'A':             /* Start assertion */
12343                     case 'b': case 'B':   /* Word-boundary assertion*/
12344                     case 'C':             /* Single char !DANGEROUS! */
12345                     case 'd': case 'D':   /* digit class */
12346                     case 'g': case 'G':   /* generic-backref, pos assertion */
12347                     case 'h': case 'H':   /* HORIZWS */
12348                     case 'k': case 'K':   /* named backref, keep marker */
12349                     case 'p': case 'P':   /* Unicode property */
12350                               case 'R':   /* LNBREAK */
12351                     case 's': case 'S':   /* space class */
12352                     case 'v': case 'V':   /* VERTWS */
12353                     case 'w': case 'W':   /* word class */
12354                     case 'X':             /* eXtended Unicode "combining
12355                                              character sequence" */
12356                     case 'z': case 'Z':   /* End of line/string assertion */
12357                         --p;
12358                         goto loopdone;
12359
12360                     /* Anything after here is an escape that resolves to a
12361                        literal. (Except digits, which may or may not)
12362                      */
12363                     case 'n':
12364                         ender = '\n';
12365                         p++;
12366                         break;
12367                     case 'N': /* Handle a single-code point named character. */
12368                         RExC_parse = p + 1;
12369                         if (! grok_bslash_N(pRExC_state,
12370                                             NULL,   /* Fail if evaluates to
12371                                                        anything other than a
12372                                                        single code point */
12373                                             &ender, /* The returned single code
12374                                                        point */
12375                                             NULL,   /* Don't need a count of
12376                                                        how many code points */
12377                                             flagp,
12378                                             depth)
12379                         ) {
12380                             if (*flagp & RESTART_UTF8)
12381                                 FAIL("panic: grok_bslash_N set RESTART_UTF8");
12382
12383                             /* Here, it wasn't a single code point.  Go close
12384                              * up this EXACTish node.  The switch() prior to
12385                              * this switch handles the other cases */
12386                             RExC_parse = p = oldp;
12387                             goto loopdone;
12388                         }
12389                         p = RExC_parse;
12390                         if (ender > 0xff) {
12391                             REQUIRE_UTF8;
12392                         }
12393                         break;
12394                     case 'r':
12395                         ender = '\r';
12396                         p++;
12397                         break;
12398                     case 't':
12399                         ender = '\t';
12400                         p++;
12401                         break;
12402                     case 'f':
12403                         ender = '\f';
12404                         p++;
12405                         break;
12406                     case 'e':
12407                         ender = ESC_NATIVE;
12408                         p++;
12409                         break;
12410                     case 'a':
12411                         ender = '\a';
12412                         p++;
12413                         break;
12414                     case 'o':
12415                         {
12416                             UV result;
12417                             const char* error_msg;
12418
12419                             bool valid = grok_bslash_o(&p,
12420                                                        &result,
12421                                                        &error_msg,
12422                                                        PASS2, /* out warnings */
12423                                                        (bool) RExC_strict,
12424                                                        TRUE, /* Output warnings
12425                                                                 for non-
12426                                                                 portables */
12427                                                        UTF);
12428                             if (! valid) {
12429                                 RExC_parse = p; /* going to die anyway; point
12430                                                    to exact spot of failure */
12431                                 vFAIL(error_msg);
12432                             }
12433                             ender = result;
12434                             if (IN_ENCODING && ender < 0x100) {
12435                                 goto recode_encoding;
12436                             }
12437                             if (ender > 0xff) {
12438                                 REQUIRE_UTF8;
12439                             }
12440                             break;
12441                         }
12442                     case 'x':
12443                         {
12444                             UV result = UV_MAX; /* initialize to erroneous
12445                                                    value */
12446                             const char* error_msg;
12447
12448                             bool valid = grok_bslash_x(&p,
12449                                                        &result,
12450                                                        &error_msg,
12451                                                        PASS2, /* out warnings */
12452                                                        (bool) RExC_strict,
12453                                                        TRUE, /* Silence warnings
12454                                                                 for non-
12455                                                                 portables */
12456                                                        UTF);
12457                             if (! valid) {
12458                                 RExC_parse = p; /* going to die anyway; point
12459                                                    to exact spot of failure */
12460                                 vFAIL(error_msg);
12461                             }
12462                             ender = result;
12463
12464                             if (ender < 0x100) {
12465 #ifdef EBCDIC
12466                                 if (RExC_recode_x_to_native) {
12467                                     ender = LATIN1_TO_NATIVE(ender);
12468                                 }
12469                                 else
12470 #endif
12471                                 if (IN_ENCODING) {
12472                                     goto recode_encoding;
12473                                 }
12474                             }
12475                             else {
12476                                 REQUIRE_UTF8;
12477                             }
12478                             break;
12479                         }
12480                     case 'c':
12481                         p++;
12482                         ender = grok_bslash_c(*p++, PASS2);
12483                         break;
12484                     case '8': case '9': /* must be a backreference */
12485                         --p;
12486                         /* we have an escape like \8 which cannot be an octal escape
12487                          * so we exit the loop, and let the outer loop handle this
12488                          * escape which may or may not be a legitimate backref. */
12489                         goto loopdone;
12490                     case '1': case '2': case '3':case '4':
12491                     case '5': case '6': case '7':
12492                         /* When we parse backslash escapes there is ambiguity
12493                          * between backreferences and octal escapes. Any escape
12494                          * from \1 - \9 is a backreference, any multi-digit
12495                          * escape which does not start with 0 and which when
12496                          * evaluated as decimal could refer to an already
12497                          * parsed capture buffer is a back reference. Anything
12498                          * else is octal.
12499                          *
12500                          * Note this implies that \118 could be interpreted as
12501                          * 118 OR as "\11" . "8" depending on whether there
12502                          * were 118 capture buffers defined already in the
12503                          * pattern.  */
12504
12505                         /* NOTE, RExC_npar is 1 more than the actual number of
12506                          * parens we have seen so far, hence the < RExC_npar below. */
12507
12508                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
12509                         {  /* Not to be treated as an octal constant, go
12510                                    find backref */
12511                             --p;
12512                             goto loopdone;
12513                         }
12514                         /* FALLTHROUGH */
12515                     case '0':
12516                         {
12517                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
12518                             STRLEN numlen = 3;
12519                             ender = grok_oct(p, &numlen, &flags, NULL);
12520                             if (ender > 0xff) {
12521                                 REQUIRE_UTF8;
12522                             }
12523                             p += numlen;
12524                             if (PASS2   /* like \08, \178 */
12525                                 && numlen < 3
12526                                 && p < RExC_end
12527                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
12528                             {
12529                                 reg_warn_non_literal_string(
12530                                          p + 1,
12531                                          form_short_octal_warning(p, numlen));
12532                             }
12533                         }
12534                         if (IN_ENCODING && ender < 0x100)
12535                             goto recode_encoding;
12536                         break;
12537                       recode_encoding:
12538                         if (! RExC_override_recoding) {
12539                             SV* enc = _get_encoding();
12540                             ender = reg_recode((const char)(U8)ender, &enc);
12541                             if (!enc && PASS2)
12542                                 ckWARNreg(p, "Invalid escape in the specified encoding");
12543                             REQUIRE_UTF8;
12544                         }
12545                         break;
12546                     case '\0':
12547                         if (p >= RExC_end)
12548                             FAIL("Trailing \\");
12549                         /* FALLTHROUGH */
12550                     default:
12551                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
12552                             /* Include any { following the alpha to emphasize
12553                              * that it could be part of an escape at some point
12554                              * in the future */
12555                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
12556                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
12557                         }
12558                         goto normal_default;
12559                     } /* End of switch on '\' */
12560                     break;
12561                 case '{':
12562                     /* Currently we don't warn when the lbrace is at the start
12563                      * of a construct.  This catches it in the middle of a
12564                      * literal string, or when its the first thing after
12565                      * something like "\b" */
12566                     if (! SIZE_ONLY
12567                         && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
12568                     {
12569                         ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
12570                     }
12571                     /*FALLTHROUGH*/
12572                 default:    /* A literal character */
12573                   normal_default:
12574                     if (UTF8_IS_START(*p) && UTF) {
12575                         STRLEN numlen;
12576                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
12577                                                &numlen, UTF8_ALLOW_DEFAULT);
12578                         p += numlen;
12579                     }
12580                     else
12581                         ender = (U8) *p++;
12582                     break;
12583                 } /* End of switch on the literal */
12584
12585                 /* Here, have looked at the literal character and <ender>
12586                  * contains its ordinal, <p> points to the character after it
12587                  */
12588
12589                 if ( RExC_flags & RXf_PMf_EXTENDED)
12590                     p = regpatws(pRExC_state, p,
12591                                           TRUE); /* means recognize comments */
12592
12593                 /* If the next thing is a quantifier, it applies to this
12594                  * character only, which means that this character has to be in
12595                  * its own node and can't just be appended to the string in an
12596                  * existing node, so if there are already other characters in
12597                  * the node, close the node with just them, and set up to do
12598                  * this character again next time through, when it will be the
12599                  * only thing in its new node */
12600                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
12601                 {
12602                     p = oldp;
12603                     goto loopdone;
12604                 }
12605
12606                 if (! FOLD) {  /* The simple case, just append the literal */
12607
12608                     /* In the sizing pass, we need only the size of the
12609                      * character we are appending, hence we can delay getting
12610                      * its representation until PASS2. */
12611                     if (SIZE_ONLY) {
12612                         if (UTF) {
12613                             const STRLEN unilen = UNISKIP(ender);
12614                             s += unilen;
12615
12616                             /* We have to subtract 1 just below (and again in
12617                              * the corresponding PASS2 code) because the loop
12618                              * increments <len> each time, as all but this path
12619                              * (and one other) through it add a single byte to
12620                              * the EXACTish node.  But these paths would change
12621                              * len to be the correct final value, so cancel out
12622                              * the increment that follows */
12623                             len += unilen - 1;
12624                         }
12625                         else {
12626                             s++;
12627                         }
12628                     } else { /* PASS2 */
12629                       not_fold_common:
12630                         if (UTF) {
12631                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
12632                             len += (char *) new_s - s - 1;
12633                             s = (char *) new_s;
12634                         }
12635                         else {
12636                             *(s++) = (char) ender;
12637                         }
12638                     }
12639                 }
12640                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
12641
12642                     /* Here are folding under /l, and the code point is
12643                      * problematic.  First, we know we can't simplify things */
12644                     maybe_exact = FALSE;
12645                     maybe_exactfu = FALSE;
12646
12647                     /* A problematic code point in this context means that its
12648                      * fold isn't known until runtime, so we can't fold it now.
12649                      * (The non-problematic code points are the above-Latin1
12650                      * ones that fold to also all above-Latin1.  Their folds
12651                      * don't vary no matter what the locale is.) But here we
12652                      * have characters whose fold depends on the locale.
12653                      * Unlike the non-folding case above, we have to keep track
12654                      * of these in the sizing pass, so that we can make sure we
12655                      * don't split too-long nodes in the middle of a potential
12656                      * multi-char fold.  And unlike the regular fold case
12657                      * handled in the else clauses below, we don't actually
12658                      * fold and don't have special cases to consider.  What we
12659                      * do for both passes is the PASS2 code for non-folding */
12660                     goto not_fold_common;
12661                 }
12662                 else /* A regular FOLD code point */
12663                     if (! ( UTF
12664                         /* See comments for join_exact() as to why we fold this
12665                          * non-UTF at compile time */
12666                         || (node_type == EXACTFU
12667                             && ender == LATIN_SMALL_LETTER_SHARP_S)))
12668                 {
12669                     /* Here, are folding and are not UTF-8 encoded; therefore
12670                      * the character must be in the range 0-255, and is not /l
12671                      * (Not /l because we already handled these under /l in
12672                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
12673                     if (IS_IN_SOME_FOLD_L1(ender)) {
12674                         maybe_exact = FALSE;
12675
12676                         /* See if the character's fold differs between /d and
12677                          * /u.  This includes the multi-char fold SHARP S to
12678                          * 'ss' */
12679                         if (maybe_exactfu
12680                             && (PL_fold[ender] != PL_fold_latin1[ender]
12681                                 || ender == LATIN_SMALL_LETTER_SHARP_S
12682                                 || (len > 0
12683                                    && isALPHA_FOLD_EQ(ender, 's')
12684                                    && isALPHA_FOLD_EQ(*(s-1), 's'))))
12685                         {
12686                             maybe_exactfu = FALSE;
12687                         }
12688                     }
12689
12690                     /* Even when folding, we store just the input character, as
12691                      * we have an array that finds its fold quickly */
12692                     *(s++) = (char) ender;
12693                 }
12694                 else {  /* FOLD and UTF */
12695                     /* Unlike the non-fold case, we do actually have to
12696                      * calculate the results here in pass 1.  This is for two
12697                      * reasons, the folded length may be longer than the
12698                      * unfolded, and we have to calculate how many EXACTish
12699                      * nodes it will take; and we may run out of room in a node
12700                      * in the middle of a potential multi-char fold, and have
12701                      * to back off accordingly.  */
12702
12703                     UV folded;
12704                     if (isASCII_uni(ender)) {
12705                         folded = toFOLD(ender);
12706                         *(s)++ = (U8) folded;
12707                     }
12708                     else {
12709                         STRLEN foldlen;
12710
12711                         folded = _to_uni_fold_flags(
12712                                      ender,
12713                                      (U8 *) s,
12714                                      &foldlen,
12715                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12716                                                         ? FOLD_FLAGS_NOMIX_ASCII
12717                                                         : 0));
12718                         s += foldlen;
12719
12720                         /* The loop increments <len> each time, as all but this
12721                          * path (and one other) through it add a single byte to
12722                          * the EXACTish node.  But this one has changed len to
12723                          * be the correct final value, so subtract one to
12724                          * cancel out the increment that follows */
12725                         len += foldlen - 1;
12726                     }
12727                     /* If this node only contains non-folding code points so
12728                      * far, see if this new one is also non-folding */
12729                     if (maybe_exact) {
12730                         if (folded != ender) {
12731                             maybe_exact = FALSE;
12732                         }
12733                         else {
12734                             /* Here the fold is the original; we have to check
12735                              * further to see if anything folds to it */
12736                             if (_invlist_contains_cp(PL_utf8_foldable,
12737                                                         ender))
12738                             {
12739                                 maybe_exact = FALSE;
12740                             }
12741                         }
12742                     }
12743                     ender = folded;
12744                 }
12745
12746                 if (next_is_quantifier) {
12747
12748                     /* Here, the next input is a quantifier, and to get here,
12749                      * the current character is the only one in the node.
12750                      * Also, here <len> doesn't include the final byte for this
12751                      * character */
12752                     len++;
12753                     goto loopdone;
12754                 }
12755
12756             } /* End of loop through literal characters */
12757
12758             /* Here we have either exhausted the input or ran out of room in
12759              * the node.  (If we encountered a character that can't be in the
12760              * node, transfer is made directly to <loopdone>, and so we
12761              * wouldn't have fallen off the end of the loop.)  In the latter
12762              * case, we artificially have to split the node into two, because
12763              * we just don't have enough space to hold everything.  This
12764              * creates a problem if the final character participates in a
12765              * multi-character fold in the non-final position, as a match that
12766              * should have occurred won't, due to the way nodes are matched,
12767              * and our artificial boundary.  So back off until we find a non-
12768              * problematic character -- one that isn't at the beginning or
12769              * middle of such a fold.  (Either it doesn't participate in any
12770              * folds, or appears only in the final position of all the folds it
12771              * does participate in.)  A better solution with far fewer false
12772              * positives, and that would fill the nodes more completely, would
12773              * be to actually have available all the multi-character folds to
12774              * test against, and to back-off only far enough to be sure that
12775              * this node isn't ending with a partial one.  <upper_parse> is set
12776              * further below (if we need to reparse the node) to include just
12777              * up through that final non-problematic character that this code
12778              * identifies, so when it is set to less than the full node, we can
12779              * skip the rest of this */
12780             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
12781
12782                 const STRLEN full_len = len;
12783
12784                 assert(len >= MAX_NODE_STRING_SIZE);
12785
12786                 /* Here, <s> points to the final byte of the final character.
12787                  * Look backwards through the string until find a non-
12788                  * problematic character */
12789
12790                 if (! UTF) {
12791
12792                     /* This has no multi-char folds to non-UTF characters */
12793                     if (ASCII_FOLD_RESTRICTED) {
12794                         goto loopdone;
12795                     }
12796
12797                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
12798                     len = s - s0 + 1;
12799                 }
12800                 else {
12801                     if (!  PL_NonL1NonFinalFold) {
12802                         PL_NonL1NonFinalFold = _new_invlist_C_array(
12803                                         NonL1_Perl_Non_Final_Folds_invlist);
12804                     }
12805
12806                     /* Point to the first byte of the final character */
12807                     s = (char *) utf8_hop((U8 *) s, -1);
12808
12809                     while (s >= s0) {   /* Search backwards until find
12810                                            non-problematic char */
12811                         if (UTF8_IS_INVARIANT(*s)) {
12812
12813                             /* There are no ascii characters that participate
12814                              * in multi-char folds under /aa.  In EBCDIC, the
12815                              * non-ascii invariants are all control characters,
12816                              * so don't ever participate in any folds. */
12817                             if (ASCII_FOLD_RESTRICTED
12818                                 || ! IS_NON_FINAL_FOLD(*s))
12819                             {
12820                                 break;
12821                             }
12822                         }
12823                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
12824                             if (! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_NATIVE(
12825                                                                   *s, *(s+1))))
12826                             {
12827                                 break;
12828                             }
12829                         }
12830                         else if (! _invlist_contains_cp(
12831                                         PL_NonL1NonFinalFold,
12832                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
12833                         {
12834                             break;
12835                         }
12836
12837                         /* Here, the current character is problematic in that
12838                          * it does occur in the non-final position of some
12839                          * fold, so try the character before it, but have to
12840                          * special case the very first byte in the string, so
12841                          * we don't read outside the string */
12842                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
12843                     } /* End of loop backwards through the string */
12844
12845                     /* If there were only problematic characters in the string,
12846                      * <s> will point to before s0, in which case the length
12847                      * should be 0, otherwise include the length of the
12848                      * non-problematic character just found */
12849                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
12850                 }
12851
12852                 /* Here, have found the final character, if any, that is
12853                  * non-problematic as far as ending the node without splitting
12854                  * it across a potential multi-char fold.  <len> contains the
12855                  * number of bytes in the node up-to and including that
12856                  * character, or is 0 if there is no such character, meaning
12857                  * the whole node contains only problematic characters.  In
12858                  * this case, give up and just take the node as-is.  We can't
12859                  * do any better */
12860                 if (len == 0) {
12861                     len = full_len;
12862
12863                     /* If the node ends in an 's' we make sure it stays EXACTF,
12864                      * as if it turns into an EXACTFU, it could later get
12865                      * joined with another 's' that would then wrongly match
12866                      * the sharp s */
12867                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
12868                     {
12869                         maybe_exactfu = FALSE;
12870                     }
12871                 } else {
12872
12873                     /* Here, the node does contain some characters that aren't
12874                      * problematic.  If one such is the final character in the
12875                      * node, we are done */
12876                     if (len == full_len) {
12877                         goto loopdone;
12878                     }
12879                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
12880
12881                         /* If the final character is problematic, but the
12882                          * penultimate is not, back-off that last character to
12883                          * later start a new node with it */
12884                         p = oldp;
12885                         goto loopdone;
12886                     }
12887
12888                     /* Here, the final non-problematic character is earlier
12889                      * in the input than the penultimate character.  What we do
12890                      * is reparse from the beginning, going up only as far as
12891                      * this final ok one, thus guaranteeing that the node ends
12892                      * in an acceptable character.  The reason we reparse is
12893                      * that we know how far in the character is, but we don't
12894                      * know how to correlate its position with the input parse.
12895                      * An alternate implementation would be to build that
12896                      * correlation as we go along during the original parse,
12897                      * but that would entail extra work for every node, whereas
12898                      * this code gets executed only when the string is too
12899                      * large for the node, and the final two characters are
12900                      * problematic, an infrequent occurrence.  Yet another
12901                      * possible strategy would be to save the tail of the
12902                      * string, and the next time regatom is called, initialize
12903                      * with that.  The problem with this is that unless you
12904                      * back off one more character, you won't be guaranteed
12905                      * regatom will get called again, unless regbranch,
12906                      * regpiece ... are also changed.  If you do back off that
12907                      * extra character, so that there is input guaranteed to
12908                      * force calling regatom, you can't handle the case where
12909                      * just the first character in the node is acceptable.  I
12910                      * (khw) decided to try this method which doesn't have that
12911                      * pitfall; if performance issues are found, we can do a
12912                      * combination of the current approach plus that one */
12913                     upper_parse = len;
12914                     len = 0;
12915                     s = s0;
12916                     goto reparse;
12917                 }
12918             }   /* End of verifying node ends with an appropriate char */
12919
12920           loopdone:   /* Jumped to when encounters something that shouldn't be
12921                          in the node */
12922
12923             /* I (khw) don't know if you can get here with zero length, but the
12924              * old code handled this situation by creating a zero-length EXACT
12925              * node.  Might as well be NOTHING instead */
12926             if (len == 0) {
12927                 OP(ret) = NOTHING;
12928             }
12929             else {
12930                 if (FOLD) {
12931                     /* If 'maybe_exact' is still set here, means there are no
12932                      * code points in the node that participate in folds;
12933                      * similarly for 'maybe_exactfu' and code points that match
12934                      * differently depending on UTF8ness of the target string
12935                      * (for /u), or depending on locale for /l */
12936                     if (maybe_exact) {
12937                         OP(ret) = (LOC)
12938                                   ? EXACTL
12939                                   : EXACT;
12940                     }
12941                     else if (maybe_exactfu) {
12942                         OP(ret) = (LOC)
12943                                   ? EXACTFLU8
12944                                   : EXACTFU;
12945                     }
12946                 }
12947                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
12948                                            FALSE /* Don't look to see if could
12949                                                     be turned into an EXACT
12950                                                     node, as we have already
12951                                                     computed that */
12952                                           );
12953             }
12954
12955             RExC_parse = p - 1;
12956             Set_Node_Cur_Length(ret, parse_start);
12957             nextchar(pRExC_state);
12958             {
12959                 /* len is STRLEN which is unsigned, need to copy to signed */
12960                 IV iv = len;
12961                 if (iv < 0)
12962                     vFAIL("Internal disaster");
12963             }
12964
12965         } /* End of label 'defchar:' */
12966         break;
12967     } /* End of giant switch on input character */
12968
12969     return(ret);
12970 }
12971
12972 STATIC char *
12973 S_regpatws(RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
12974 {
12975     /* Returns the next non-pattern-white space, non-comment character (the
12976      * latter only if 'recognize_comment is true) in the string p, which is
12977      * ended by RExC_end.  See also reg_skipcomment */
12978     const char *e = RExC_end;
12979
12980     PERL_ARGS_ASSERT_REGPATWS;
12981
12982     while (p < e) {
12983         STRLEN len;
12984         if ((len = is_PATWS_safe(p, e, UTF))) {
12985             p += len;
12986         }
12987         else if (recognize_comment && *p == '#') {
12988             p = reg_skipcomment(pRExC_state, p);
12989         }
12990         else
12991             break;
12992     }
12993     return p;
12994 }
12995
12996 STATIC void
12997 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
12998 {
12999     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13000      * sets up the bitmap and any flags, removing those code points from the
13001      * inversion list, setting it to NULL should it become completely empty */
13002
13003     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13004     assert(PL_regkind[OP(node)] == ANYOF);
13005
13006     ANYOF_BITMAP_ZERO(node);
13007     if (*invlist_ptr) {
13008
13009         /* This gets set if we actually need to modify things */
13010         bool change_invlist = FALSE;
13011
13012         UV start, end;
13013
13014         /* Start looking through *invlist_ptr */
13015         invlist_iterinit(*invlist_ptr);
13016         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13017             UV high;
13018             int i;
13019
13020             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13021                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13022             }
13023             else if (end >= NUM_ANYOF_CODE_POINTS) {
13024                 ANYOF_FLAGS(node) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES;
13025             }
13026
13027             /* Quit if are above what we should change */
13028             if (start >= NUM_ANYOF_CODE_POINTS) {
13029                 break;
13030             }
13031
13032             change_invlist = TRUE;
13033
13034             /* Set all the bits in the range, up to the max that we are doing */
13035             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13036                    ? end
13037                    : NUM_ANYOF_CODE_POINTS - 1;
13038             for (i = start; i <= (int) high; i++) {
13039                 if (! ANYOF_BITMAP_TEST(node, i)) {
13040                     ANYOF_BITMAP_SET(node, i);
13041                 }
13042             }
13043         }
13044         invlist_iterfinish(*invlist_ptr);
13045
13046         /* Done with loop; remove any code points that are in the bitmap from
13047          * *invlist_ptr; similarly for code points above the bitmap if we have
13048          * a flag to match all of them anyways */
13049         if (change_invlist) {
13050             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13051         }
13052         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13053             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13054         }
13055
13056         /* If have completely emptied it, remove it completely */
13057         if (_invlist_len(*invlist_ptr) == 0) {
13058             SvREFCNT_dec_NN(*invlist_ptr);
13059             *invlist_ptr = NULL;
13060         }
13061     }
13062 }
13063
13064 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
13065    Character classes ([:foo:]) can also be negated ([:^foo:]).
13066    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
13067    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
13068    but trigger failures because they are currently unimplemented. */
13069
13070 #define POSIXCC_DONE(c)   ((c) == ':')
13071 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
13072 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
13073
13074 PERL_STATIC_INLINE I32
13075 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
13076 {
13077     I32 namedclass = OOB_NAMEDCLASS;
13078
13079     PERL_ARGS_ASSERT_REGPPOSIXCC;
13080
13081     if (value == '[' && RExC_parse + 1 < RExC_end &&
13082         /* I smell either [: or [= or [. -- POSIX has been here, right? */
13083         POSIXCC(UCHARAT(RExC_parse)))
13084     {
13085         const char c = UCHARAT(RExC_parse);
13086         char* const s = RExC_parse++;
13087
13088         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
13089             RExC_parse++;
13090         if (RExC_parse == RExC_end) {
13091             if (strict) {
13092
13093                 /* Try to give a better location for the error (than the end of
13094                  * the string) by looking for the matching ']' */
13095                 RExC_parse = s;
13096                 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
13097                     RExC_parse++;
13098                 }
13099                 vFAIL2("Unmatched '%c' in POSIX class", c);
13100             }
13101             /* Grandfather lone [:, [=, [. */
13102             RExC_parse = s;
13103         }
13104         else {
13105             const char* const t = RExC_parse++; /* skip over the c */
13106             assert(*t == c);
13107
13108             if (UCHARAT(RExC_parse) == ']') {
13109                 const char *posixcc = s + 1;
13110                 RExC_parse++; /* skip over the ending ] */
13111
13112                 if (*s == ':') {
13113                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
13114                     const I32 skip = t - posixcc;
13115
13116                     /* Initially switch on the length of the name.  */
13117                     switch (skip) {
13118                     case 4:
13119                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
13120                                                           this is the Perl \w
13121                                                         */
13122                             namedclass = ANYOF_WORDCHAR;
13123                         break;
13124                     case 5:
13125                         /* Names all of length 5.  */
13126                         /* alnum alpha ascii blank cntrl digit graph lower
13127                            print punct space upper  */
13128                         /* Offset 4 gives the best switch position.  */
13129                         switch (posixcc[4]) {
13130                         case 'a':
13131                             if (memEQ(posixcc, "alph", 4)) /* alpha */
13132                                 namedclass = ANYOF_ALPHA;
13133                             break;
13134                         case 'e':
13135                             if (memEQ(posixcc, "spac", 4)) /* space */
13136                                 namedclass = ANYOF_SPACE;
13137                             break;
13138                         case 'h':
13139                             if (memEQ(posixcc, "grap", 4)) /* graph */
13140                                 namedclass = ANYOF_GRAPH;
13141                             break;
13142                         case 'i':
13143                             if (memEQ(posixcc, "asci", 4)) /* ascii */
13144                                 namedclass = ANYOF_ASCII;
13145                             break;
13146                         case 'k':
13147                             if (memEQ(posixcc, "blan", 4)) /* blank */
13148                                 namedclass = ANYOF_BLANK;
13149                             break;
13150                         case 'l':
13151                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
13152                                 namedclass = ANYOF_CNTRL;
13153                             break;
13154                         case 'm':
13155                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
13156                                 namedclass = ANYOF_ALPHANUMERIC;
13157                             break;
13158                         case 'r':
13159                             if (memEQ(posixcc, "lowe", 4)) /* lower */
13160                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
13161                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
13162                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
13163                             break;
13164                         case 't':
13165                             if (memEQ(posixcc, "digi", 4)) /* digit */
13166                                 namedclass = ANYOF_DIGIT;
13167                             else if (memEQ(posixcc, "prin", 4)) /* print */
13168                                 namedclass = ANYOF_PRINT;
13169                             else if (memEQ(posixcc, "punc", 4)) /* punct */
13170                                 namedclass = ANYOF_PUNCT;
13171                             break;
13172                         }
13173                         break;
13174                     case 6:
13175                         if (memEQ(posixcc, "xdigit", 6))
13176                             namedclass = ANYOF_XDIGIT;
13177                         break;
13178                     }
13179
13180                     if (namedclass == OOB_NAMEDCLASS)
13181                         vFAIL2utf8f(
13182                             "POSIX class [:%"UTF8f":] unknown",
13183                             UTF8fARG(UTF, t - s - 1, s + 1));
13184
13185                     /* The #defines are structured so each complement is +1 to
13186                      * the normal one */
13187                     if (complement) {
13188                         namedclass++;
13189                     }
13190                     assert (posixcc[skip] == ':');
13191                     assert (posixcc[skip+1] == ']');
13192                 } else if (!SIZE_ONLY) {
13193                     /* [[=foo=]] and [[.foo.]] are still future. */
13194
13195                     /* adjust RExC_parse so the warning shows after
13196                        the class closes */
13197                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
13198                         RExC_parse++;
13199                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
13200                 }
13201             } else {
13202                 /* Maternal grandfather:
13203                  * "[:" ending in ":" but not in ":]" */
13204                 if (strict) {
13205                     vFAIL("Unmatched '[' in POSIX class");
13206                 }
13207
13208                 /* Grandfather lone [:, [=, [. */
13209                 RExC_parse = s;
13210             }
13211         }
13212     }
13213
13214     return namedclass;
13215 }
13216
13217 STATIC bool
13218 S_could_it_be_a_POSIX_class(RExC_state_t *pRExC_state)
13219 {
13220     /* This applies some heuristics at the current parse position (which should
13221      * be at a '[') to see if what follows might be intended to be a [:posix:]
13222      * class.  It returns true if it really is a posix class, of course, but it
13223      * also can return true if it thinks that what was intended was a posix
13224      * class that didn't quite make it.
13225      *
13226      * It will return true for
13227      *      [:alphanumerics:
13228      *      [:alphanumerics]  (as long as the ] isn't followed immediately by a
13229      *                         ')' indicating the end of the (?[
13230      *      [:any garbage including %^&$ punctuation:]
13231      *
13232      * This is designed to be called only from S_handle_regex_sets; it could be
13233      * easily adapted to be called from the spot at the beginning of regclass()
13234      * that checks to see in a normal bracketed class if the surrounding []
13235      * have been omitted ([:word:] instead of [[:word:]]).  But doing so would
13236      * change long-standing behavior, so I (khw) didn't do that */
13237     char* p = RExC_parse + 1;
13238     char first_char = *p;
13239
13240     PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
13241
13242     assert(*(p - 1) == '[');
13243
13244     if (! POSIXCC(first_char)) {
13245         return FALSE;
13246     }
13247
13248     p++;
13249     while (p < RExC_end && isWORDCHAR(*p)) p++;
13250
13251     if (p >= RExC_end) {
13252         return FALSE;
13253     }
13254
13255     if (p - RExC_parse > 2    /* Got at least 1 word character */
13256         && (*p == first_char
13257             || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
13258     {
13259         return TRUE;
13260     }
13261
13262     p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
13263
13264     return (p
13265             && p - RExC_parse > 2 /* [:] evaluates to colon;
13266                                       [::] is a bad posix class. */
13267             && first_char == *(p - 1));
13268 }
13269
13270 STATIC unsigned  int
13271 S_regex_set_precedence(const U8 my_operator) {
13272
13273     /* Returns the precedence in the (?[...]) construct of the input operator,
13274      * specified by its character representation.  The precedence follows
13275      * general Perl rules, but it extends this so that ')' and ']' have (low)
13276      * precedence even though they aren't really operators */
13277
13278     switch (my_operator) {
13279         case '!':
13280             return 5;
13281         case '&':
13282             return 4;
13283         case '^':
13284         case '|':
13285         case '+':
13286         case '-':
13287             return 3;
13288         case ')':
13289             return 2;
13290         case ']':
13291             return 1;
13292     }
13293
13294     NOT_REACHED; /* NOTREACHED */
13295     return 0;   /* Silence compiler warning */
13296 }
13297
13298 STATIC regnode *
13299 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
13300                     I32 *flagp, U32 depth,
13301                     char * const oregcomp_parse)
13302 {
13303     /* Handle the (?[...]) construct to do set operations */
13304
13305     U8 curchar;                     /* Current character being parsed */
13306     UV start, end;                  /* End points of code point ranges */
13307     SV* final = NULL;               /* The end result inversion list */
13308     SV* result_string;              /* 'final' stringified */
13309     AV* stack;                      /* stack of operators and operands not yet
13310                                        resolved */
13311     AV* fence_stack = NULL;         /* A stack containing the positions in
13312                                        'stack' of where the undealt-with left
13313                                        parens would be if they were actually
13314                                        put there */
13315     IV fence = 0;                   /* Position of where most recent undealt-
13316                                        with left paren in stack is; -1 if none.
13317                                      */
13318     STRLEN len;                     /* Temporary */
13319     regnode* node;                  /* Temporary, and final regnode returned by
13320                                        this function */
13321     const bool save_fold = FOLD;    /* Temporary */
13322     char *save_end, *save_parse;    /* Temporaries */
13323
13324     GET_RE_DEBUG_FLAGS_DECL;
13325
13326     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
13327
13328     if (LOC) {  /* XXX could make valid in UTF-8 locales */
13329         vFAIL("(?[...]) not valid in locale");
13330     }
13331     RExC_uni_semantics = 1;     /* The use of this operator implies /u.  This
13332                                    is required so that the compile time values
13333                                    are valid in all runtime cases */
13334
13335     /* This will return only an ANYOF regnode, or (unlikely) something smaller
13336      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
13337      * call regclass to handle '[]' so as to not have to reinvent its parsing
13338      * rules here (throwing away the size it computes each time).  And, we exit
13339      * upon an unescaped ']' that isn't one ending a regclass.  To do both
13340      * these things, we need to realize that something preceded by a backslash
13341      * is escaped, so we have to keep track of backslashes */
13342     if (SIZE_ONLY) {
13343         UV depth = 0; /* how many nested (?[...]) constructs */
13344
13345         while (RExC_parse < RExC_end) {
13346             SV* current = NULL;
13347             RExC_parse = regpatws(pRExC_state, RExC_parse,
13348                                           TRUE); /* means recognize comments */
13349             switch (*RExC_parse) {
13350                 case '?':
13351                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
13352                     /* FALLTHROUGH */
13353                 default:
13354                     break;
13355                 case '\\':
13356                     /* Skip the next byte (which could cause us to end up in
13357                      * the middle of a UTF-8 character, but since none of those
13358                      * are confusable with anything we currently handle in this
13359                      * switch (invariants all), it's safe.  We'll just hit the
13360                      * default: case next time and keep on incrementing until
13361                      * we find one of the invariants we do handle. */
13362                     RExC_parse++;
13363                     break;
13364                 case '[':
13365                 {
13366                     /* If this looks like it is a [:posix:] class, leave the
13367                      * parse pointer at the '[' to fool regclass() into
13368                      * thinking it is part of a '[[:posix:]]'.  That function
13369                      * will use strict checking to force a syntax error if it
13370                      * doesn't work out to a legitimate class */
13371                     bool is_posix_class
13372                                     = could_it_be_a_POSIX_class(pRExC_state);
13373                     if (! is_posix_class) {
13374                         RExC_parse++;
13375                     }
13376
13377                     /* regclass() can only return RESTART_UTF8 if multi-char
13378                        folds are allowed.  */
13379                     if (!regclass(pRExC_state, flagp,depth+1,
13380                                   is_posix_class, /* parse the whole char
13381                                                      class only if not a
13382                                                      posix class */
13383                                   FALSE, /* don't allow multi-char folds */
13384                                   TRUE, /* silence non-portable warnings. */
13385                                   TRUE, /* strict */
13386                                   &current
13387                                  ))
13388                         FAIL2("panic: regclass returned NULL to handle_sets, "
13389                               "flags=%#"UVxf"", (UV) *flagp);
13390
13391                     /* function call leaves parse pointing to the ']', except
13392                      * if we faked it */
13393                     if (is_posix_class) {
13394                         RExC_parse--;
13395                     }
13396
13397                     SvREFCNT_dec(current);   /* In case it returned something */
13398                     break;
13399                 }
13400
13401                 case ']':
13402                     if (depth--) break;
13403                     RExC_parse++;
13404                     if (RExC_parse < RExC_end
13405                         && *RExC_parse == ')')
13406                     {
13407                         node = reganode(pRExC_state, ANYOF, 0);
13408                         RExC_size += ANYOF_SKIP;
13409                         nextchar(pRExC_state);
13410                         Set_Node_Length(node,
13411                                 RExC_parse - oregcomp_parse + 1); /* MJD */
13412                         return node;
13413                     }
13414                     goto no_close;
13415             }
13416             RExC_parse++;
13417         }
13418
13419       no_close:
13420         FAIL("Syntax error in (?[...])");
13421     }
13422
13423     /* Pass 2 only after this. */
13424     Perl_ck_warner_d(aTHX_
13425         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
13426         "The regex_sets feature is experimental" REPORT_LOCATION,
13427             UTF8fARG(UTF, (RExC_parse - RExC_precomp), RExC_precomp),
13428             UTF8fARG(UTF,
13429                      RExC_end - RExC_start - (RExC_parse - RExC_precomp),
13430                      RExC_precomp + (RExC_parse - RExC_precomp)));
13431
13432     /* Everything in this construct is a metacharacter.  Operands begin with
13433      * either a '\' (for an escape sequence), or a '[' for a bracketed
13434      * character class.  Any other character should be an operator, or
13435      * parenthesis for grouping.  Both types of operands are handled by calling
13436      * regclass() to parse them.  It is called with a parameter to indicate to
13437      * return the computed inversion list.  The parsing here is implemented via
13438      * a stack.  Each entry on the stack is a single character representing one
13439      * of the operators; or else a pointer to an operand inversion list. */
13440
13441 #define IS_OPERAND(a)  (! SvIOK(a))
13442
13443     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
13444      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
13445      * with prounouncing it called it Reverse Polish instead, but now that YOU
13446      * know how to prounounce it you can use the correct term, thus giving due
13447      * credit to the person who invented it, and impressing your geek friends.
13448      * Wikipedia says that the pronounciation of "Ł" has been changing so that
13449      * it is now more like an English initial W (as in wonk) than an L.)
13450      *
13451      * This means that, for example, 'a | b & c' is stored on the stack as
13452      *
13453      * c  [4]
13454      * b  [3]
13455      * &  [2]
13456      * a  [1]
13457      * |  [0]
13458      *
13459      * where the numbers in brackets give the stack [array] element number.
13460      * In this implementation, parentheses are not stored on the stack.
13461      * Instead a '(' creates a "fence" so that the part of the stack below the
13462      * fence is invisible except to the corresponding ')' (this allows us to
13463      * replace testing for parens, by using instead subtraction of the fence
13464      * position).  As new operands are processed they are pushed onto the stack
13465      * (except as noted in the next paragraph).  New operators of higher
13466      * precedence than the current final one are inserted on the stack before
13467      * the lhs operand (so that when the rhs is pushed next, everything will be
13468      * in the correct positions shown above.  When an operator of equal or
13469      * lower precedence is encountered in parsing, all the stacked operations
13470      * of equal or higher precedence are evaluated, leaving the result as the
13471      * top entry on the stack.  This makes higher precedence operations
13472      * evaluate before lower precedence ones, and causes operations of equal
13473      * precedence to left associate.
13474      *
13475      * The only unary operator '!' is immediately pushed onto the stack when
13476      * encountered.  When an operand is encountered, if the top of the stack is
13477      * a '!", the complement is immediately performed, and the '!' popped.  The
13478      * resulting value is treated as a new operand, and the logic in the
13479      * previous paragraph is executed.  Thus in the expression
13480      *      [a] + ! [b]
13481      * the stack looks like
13482      *
13483      * !
13484      * a
13485      * +
13486      *
13487      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
13488      * becomes
13489      *
13490      * !b
13491      * a
13492      * +
13493      *
13494      * A ')' is treated as an operator with lower precedence than all the
13495      * aforementioned ones, which causes all operations on the stack above the
13496      * corresponding '(' to be evaluated down to a single resultant operand.
13497      * Then the fence for the '(' is removed, and the operand goes through the
13498      * algorithm above, without the fence.
13499      *
13500      * A separate stack is kept of the fence positions, so that the position of
13501      * the latest so-far unbalanced '(' is at the top of it.
13502      *
13503      * The ']' ending the construct is treated as the lowest operator of all,
13504      * so that everything gets evaluated down to a single operand, which is the
13505      * result */
13506
13507     sv_2mortal((SV *)(stack = newAV()));
13508     sv_2mortal((SV *)(fence_stack = newAV()));
13509
13510     while (RExC_parse < RExC_end) {
13511         I32 top_index;              /* Index of top-most element in 'stack' */
13512         SV** top_ptr;               /* Pointer to top 'stack' element */
13513         SV* current = NULL;         /* To contain the current inversion list
13514                                        operand */
13515         SV* only_to_avoid_leaks;
13516
13517         /* Skip white space */
13518         RExC_parse = regpatws(pRExC_state, RExC_parse,
13519                 TRUE /* means recognize comments */ );
13520         if (RExC_parse >= RExC_end) {
13521             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
13522         }
13523
13524         curchar = UCHARAT(RExC_parse);
13525
13526 redo_curchar:
13527
13528         top_index = av_tindex(stack);
13529
13530         switch (curchar) {
13531             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
13532             char stacked_operator;  /* The topmost operator on the 'stack'. */
13533             SV* lhs;                /* Operand to the left of the operator */
13534             SV* rhs;                /* Operand to the right of the operator */
13535             SV* fence_ptr;          /* Pointer to top element of the fence
13536                                        stack */
13537
13538             case '(':
13539
13540                 if (RExC_parse < RExC_end && (UCHARAT(RExC_parse + 1) == '?'))
13541                 {
13542                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
13543                      * This happens when we have some thing like
13544                      *
13545                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
13546                      *   ...
13547                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
13548                      *
13549                      * Here we would be handling the interpolated
13550                      * '$thai_or_lao'.  We handle this by a recursive call to
13551                      * ourselves which returns the inversion list the
13552                      * interpolated expression evaluates to.  We use the flags
13553                      * from the interpolated pattern. */
13554                     U32 save_flags = RExC_flags;
13555                     const char * save_parse;
13556
13557                     RExC_parse += 2;        /* Skip past the '(?' */
13558                     save_parse = RExC_parse;
13559
13560                     /* Parse any flags for the '(?' */
13561                     parse_lparen_question_flags(pRExC_state);
13562
13563                     if (RExC_parse == save_parse  /* Makes sure there was at
13564                                                      least one flag (or else
13565                                                      this embedding wasn't
13566                                                      compiled) */
13567                         || RExC_parse >= RExC_end - 4
13568                         || UCHARAT(RExC_parse) != ':'
13569                         || UCHARAT(++RExC_parse) != '('
13570                         || UCHARAT(++RExC_parse) != '?'
13571                         || UCHARAT(++RExC_parse) != '[')
13572                     {
13573
13574                         /* In combination with the above, this moves the
13575                          * pointer to the point just after the first erroneous
13576                          * character (or if there are no flags, to where they
13577                          * should have been) */
13578                         if (RExC_parse >= RExC_end - 4) {
13579                             RExC_parse = RExC_end;
13580                         }
13581                         else if (RExC_parse != save_parse) {
13582                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13583                         }
13584                         vFAIL("Expecting '(?flags:(?[...'");
13585                     }
13586
13587                     /* Recurse, with the meat of the embedded expression */
13588                     RExC_parse++;
13589                     (void) handle_regex_sets(pRExC_state, &current, flagp,
13590                                                     depth+1, oregcomp_parse);
13591
13592                     /* Here, 'current' contains the embedded expression's
13593                      * inversion list, and RExC_parse points to the trailing
13594                      * ']'; the next character should be the ')' */
13595                     RExC_parse++;
13596                     assert(RExC_parse < RExC_end && UCHARAT(RExC_parse) == ')');
13597
13598                     /* Then the ')' matching the original '(' handled by this
13599                      * case: statement */
13600                     RExC_parse++;
13601                     assert(RExC_parse < RExC_end && UCHARAT(RExC_parse) == ')');
13602
13603                     RExC_parse++;
13604                     RExC_flags = save_flags;
13605                     goto handle_operand;
13606                 }
13607
13608                 /* A regular '('.  Look behind for illegal syntax */
13609                 if (top_index - fence >= 0) {
13610                     /* If the top entry on the stack is an operator, it had
13611                      * better be a '!', otherwise the entry below the top
13612                      * operand should be an operator */
13613                     if ( ! (top_ptr = av_fetch(stack, top_index, FALSE))
13614                         || (! IS_OPERAND(*top_ptr) && SvUV(*top_ptr) != '!')
13615                         || top_index - fence < 1
13616                         || ! (stacked_ptr = av_fetch(stack,
13617                                                      top_index - 1,
13618                                                      FALSE))
13619                         || IS_OPERAND(*stacked_ptr))
13620                     {
13621                         RExC_parse++;
13622                         vFAIL("Unexpected '(' with no preceding operator");
13623                     }
13624                 }
13625
13626                 /* Stack the position of this undealt-with left paren */
13627                 fence = top_index + 1;
13628                 av_push(fence_stack, newSViv(fence));
13629                 break;
13630
13631             case '\\':
13632                 /* regclass() can only return RESTART_UTF8 if multi-char
13633                    folds are allowed.  */
13634                 if (!regclass(pRExC_state, flagp,depth+1,
13635                               TRUE, /* means parse just the next thing */
13636                               FALSE, /* don't allow multi-char folds */
13637                               FALSE, /* don't silence non-portable warnings.  */
13638                               TRUE,  /* strict */
13639                               &current))
13640                 {
13641                     FAIL2("panic: regclass returned NULL to handle_sets, "
13642                           "flags=%#"UVxf"", (UV) *flagp);
13643                 }
13644
13645                 /* regclass() will return with parsing just the \ sequence,
13646                  * leaving the parse pointer at the next thing to parse */
13647                 RExC_parse--;
13648                 goto handle_operand;
13649
13650             case '[':   /* Is a bracketed character class */
13651             {
13652                 bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
13653
13654                 if (! is_posix_class) {
13655                     RExC_parse++;
13656                 }
13657
13658                 /* regclass() can only return RESTART_UTF8 if multi-char
13659                    folds are allowed.  */
13660                 if(!regclass(pRExC_state, flagp,depth+1,
13661                              is_posix_class, /* parse the whole char class
13662                                                 only if not a posix class */
13663                              FALSE, /* don't allow multi-char folds */
13664                              FALSE, /* don't silence non-portable warnings.  */
13665                              TRUE,   /* strict */
13666                              &current
13667                             ))
13668                 {
13669                     FAIL2("panic: regclass returned NULL to handle_sets, "
13670                           "flags=%#"UVxf"", (UV) *flagp);
13671                 }
13672
13673                 /* function call leaves parse pointing to the ']', except if we
13674                  * faked it */
13675                 if (is_posix_class) {
13676                     RExC_parse--;
13677                 }
13678
13679                 goto handle_operand;
13680             }
13681
13682             case ']':
13683                 if (top_index >= 1) {
13684                     goto join_operators;
13685                 }
13686
13687                 /* Only a single operand on the stack: are done */
13688                 goto done;
13689
13690             case ')':
13691                 if (av_tindex(fence_stack) < 0) {
13692                     RExC_parse++;
13693                     vFAIL("Unexpected ')'");
13694                 }
13695
13696                  /* If at least two thing on the stack, treat this as an
13697                   * operator */
13698                 if (top_index - fence >= 1) {
13699                     goto join_operators;
13700                 }
13701
13702                 /* Here only a single thing on the fenced stack, and there is a
13703                  * fence.  Get rid of it */
13704                 fence_ptr = av_pop(fence_stack);
13705                 assert(fence_ptr);
13706                 fence = SvIV(fence_ptr) - 1;
13707                 SvREFCNT_dec_NN(fence_ptr);
13708                 fence_ptr = NULL;
13709
13710                 if (fence < 0) {
13711                     fence = 0;
13712                 }
13713
13714                 /* Having gotten rid of the fence, we pop the operand at the
13715                  * stack top and process it as a newly encountered operand */
13716                 current = av_pop(stack);
13717                 assert(IS_OPERAND(current));
13718                 goto handle_operand;
13719
13720             case '&':
13721             case '|':
13722             case '+':
13723             case '-':
13724             case '^':
13725
13726                 /* These binary operators should have a left operand already
13727                  * parsed */
13728                 if (   top_index - fence < 0
13729                     || top_index - fence == 1
13730                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
13731                     || ! IS_OPERAND(*top_ptr))
13732                 {
13733                     goto unexpected_binary;
13734                 }
13735
13736                 /* If only the one operand is on the part of the stack visible
13737                  * to us, we just place this operator in the proper position */
13738                 if (top_index - fence < 2) {
13739
13740                     /* Place the operator before the operand */
13741
13742                     SV* lhs = av_pop(stack);
13743                     av_push(stack, newSVuv(curchar));
13744                     av_push(stack, lhs);
13745                     break;
13746                 }
13747
13748                 /* But if there is something else on the stack, we need to
13749                  * process it before this new operator if and only if the
13750                  * stacked operation has equal or higher precedence than the
13751                  * new one */
13752
13753              join_operators:
13754
13755                 /* The operator on the stack is supposed to be below both its
13756                  * operands */
13757                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
13758                     || IS_OPERAND(*stacked_ptr))
13759                 {
13760                     /* But if not, it's legal and indicates we are completely
13761                      * done if and only if we're currently processing a ']',
13762                      * which should be the final thing in the expression */
13763                     if (curchar == ']') {
13764                         goto done;
13765                     }
13766
13767                   unexpected_binary:
13768                     RExC_parse++;
13769                     vFAIL2("Unexpected binary operator '%c' with no "
13770                            "preceding operand", curchar);
13771                 }
13772                 stacked_operator = (char) SvUV(*stacked_ptr);
13773
13774                 if (regex_set_precedence(curchar)
13775                     > regex_set_precedence(stacked_operator))
13776                 {
13777                     /* Here, the new operator has higher precedence than the
13778                      * stacked one.  This means we need to add the new one to
13779                      * the stack to await its rhs operand (and maybe more
13780                      * stuff).  We put it before the lhs operand, leaving
13781                      * untouched the stacked operator and everything below it
13782                      * */
13783                     lhs = av_pop(stack);
13784                     assert(IS_OPERAND(lhs));
13785
13786                     av_push(stack, newSVuv(curchar));
13787                     av_push(stack, lhs);
13788                     break;
13789                 }
13790
13791                 /* Here, the new operator has equal or lower precedence than
13792                  * what's already there.  This means the operation already
13793                  * there should be performed now, before the new one. */
13794                 rhs = av_pop(stack);
13795                 lhs = av_pop(stack);
13796
13797                 assert(IS_OPERAND(rhs));
13798                 assert(IS_OPERAND(lhs));
13799
13800                 switch (stacked_operator) {
13801                     case '&':
13802                         _invlist_intersection(lhs, rhs, &rhs);
13803                         break;
13804
13805                     case '|':
13806                     case '+':
13807                         _invlist_union(lhs, rhs, &rhs);
13808                         break;
13809
13810                     case '-':
13811                         _invlist_subtract(lhs, rhs, &rhs);
13812                         break;
13813
13814                     case '^':   /* The union minus the intersection */
13815                     {
13816                         SV* i = NULL;
13817                         SV* u = NULL;
13818                         SV* element;
13819
13820                         _invlist_union(lhs, rhs, &u);
13821                         _invlist_intersection(lhs, rhs, &i);
13822                         /* _invlist_subtract will overwrite rhs
13823                             without freeing what it already contains */
13824                         element = rhs;
13825                         _invlist_subtract(u, i, &rhs);
13826                         SvREFCNT_dec_NN(i);
13827                         SvREFCNT_dec_NN(u);
13828                         SvREFCNT_dec_NN(element);
13829                         break;
13830                     }
13831                 }
13832                 SvREFCNT_dec(lhs);
13833
13834                 /* Here, the higher precedence operation has been done, and the
13835                  * result is in 'rhs'.  We overwrite the stacked operator with
13836                  * the result.  Then we redo this code to either push the new
13837                  * operator onto the stack or perform any higher precedence
13838                  * stacked operation */
13839                 only_to_avoid_leaks = av_pop(stack);
13840                 SvREFCNT_dec(only_to_avoid_leaks);
13841                 av_push(stack, rhs);
13842                 goto redo_curchar;
13843
13844             case '!':   /* Highest priority, right associative, so just push
13845                            onto stack */
13846                 av_push(stack, newSVuv(curchar));
13847                 break;
13848
13849             default:
13850                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13851                 vFAIL("Unexpected character");
13852
13853           handle_operand:
13854
13855             /* Here 'current' is the operand.  If something is already on the
13856              * stack, we have to check if it is a !. */
13857             top_index = av_tindex(stack);   /* Code above may have altered the
13858                                              * stack in the time since we
13859                                              * earlier set 'top_index'. */
13860             if (top_index - fence >= 0) {
13861                 /* If the top entry on the stack is an operator, it had better
13862                  * be a '!', otherwise the entry below the top operand should
13863                  * be an operator */
13864                 top_ptr = av_fetch(stack, top_index, FALSE);
13865                 assert(top_ptr);
13866                 if (! IS_OPERAND(*top_ptr)) {
13867
13868                     /* The only permissible operator at the top of the stack is
13869                      * '!', which is applied immediately to this operand. */
13870                     curchar = (char) SvUV(*top_ptr);
13871                     if (curchar != '!') {
13872                         SvREFCNT_dec(current);
13873                         vFAIL2("Unexpected binary operator '%c' with no "
13874                                 "preceding operand", curchar);
13875                     }
13876
13877                     _invlist_invert(current);
13878
13879                     only_to_avoid_leaks = av_pop(stack);
13880                     SvREFCNT_dec(only_to_avoid_leaks);
13881                     top_index = av_tindex(stack);
13882
13883                     /* And we redo with the inverted operand.  This allows
13884                      * handling multiple ! in a row */
13885                     goto handle_operand;
13886                 }
13887                           /* Single operand is ok only for the non-binary ')'
13888                            * operator */
13889                 else if ((top_index - fence == 0 && curchar != ')')
13890                          || (top_index - fence > 0
13891                              && (! (stacked_ptr = av_fetch(stack,
13892                                                            top_index - 1,
13893                                                            FALSE))
13894                                  || IS_OPERAND(*stacked_ptr))))
13895                 {
13896                     SvREFCNT_dec(current);
13897                     vFAIL("Operand with no preceding operator");
13898                 }
13899             }
13900
13901             /* Here there was nothing on the stack or the top element was
13902              * another operand.  Just add this new one */
13903             av_push(stack, current);
13904
13905         } /* End of switch on next parse token */
13906
13907         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13908     } /* End of loop parsing through the construct */
13909
13910   done:
13911     if (av_tindex(fence_stack) >= 0) {
13912         vFAIL("Unmatched (");
13913     }
13914
13915     if (av_tindex(stack) < 0   /* Was empty */
13916         || ((final = av_pop(stack)) == NULL)
13917         || ! IS_OPERAND(final)
13918         || av_tindex(stack) >= 0)  /* More left on stack */
13919     {
13920         SvREFCNT_dec(final);
13921         vFAIL("Incomplete expression within '(?[ ])'");
13922     }
13923
13924     /* Here, 'final' is the resultant inversion list from evaluating the
13925      * expression.  Return it if so requested */
13926     if (return_invlist) {
13927         *return_invlist = final;
13928         return END;
13929     }
13930
13931     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
13932      * expecting a string of ranges and individual code points */
13933     invlist_iterinit(final);
13934     result_string = newSVpvs("");
13935     while (invlist_iternext(final, &start, &end)) {
13936         if (start == end) {
13937             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
13938         }
13939         else {
13940             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
13941                                                      start,          end);
13942         }
13943     }
13944
13945     /* About to generate an ANYOF (or similar) node from the inversion list we
13946      * have calculated */
13947     save_parse = RExC_parse;
13948     RExC_parse = SvPV(result_string, len);
13949     save_end = RExC_end;
13950     RExC_end = RExC_parse + len;
13951
13952     /* We turn off folding around the call, as the class we have constructed
13953      * already has all folding taken into consideration, and we don't want
13954      * regclass() to add to that */
13955     RExC_flags &= ~RXf_PMf_FOLD;
13956     /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
13957      */
13958     node = regclass(pRExC_state, flagp,depth+1,
13959                     FALSE, /* means parse the whole char class */
13960                     FALSE, /* don't allow multi-char folds */
13961                     TRUE, /* silence non-portable warnings.  The above may very
13962                              well have generated non-portable code points, but
13963                              they're valid on this machine */
13964                     FALSE, /* similarly, no need for strict */
13965                     NULL
13966                 );
13967     if (!node)
13968         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
13969                     PTR2UV(flagp));
13970     if (save_fold) {
13971         RExC_flags |= RXf_PMf_FOLD;
13972     }
13973     RExC_parse = save_parse + 1;
13974     RExC_end = save_end;
13975     SvREFCNT_dec_NN(final);
13976     SvREFCNT_dec_NN(result_string);
13977
13978     nextchar(pRExC_state);
13979     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
13980     return node;
13981 }
13982 #undef IS_OPERAND
13983
13984 STATIC void
13985 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
13986 {
13987     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
13988      * innocent-looking character class, like /[ks]/i won't have to go out to
13989      * disk to find the possible matches.
13990      *
13991      * This should be called only for a Latin1-range code points, cp, which is
13992      * known to be involved in a simple fold with other code points above
13993      * Latin1.  It would give false results if /aa has been specified.
13994      * Multi-char folds are outside the scope of this, and must be handled
13995      * specially.
13996      *
13997      * XXX It would be better to generate these via regen, in case a new
13998      * version of the Unicode standard adds new mappings, though that is not
13999      * really likely, and may be caught by the default: case of the switch
14000      * below. */
14001
14002     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
14003
14004     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
14005
14006     switch (cp) {
14007         case 'k':
14008         case 'K':
14009           *invlist =
14010              add_cp_to_invlist(*invlist, KELVIN_SIGN);
14011             break;
14012         case 's':
14013         case 'S':
14014           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
14015             break;
14016         case MICRO_SIGN:
14017           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
14018           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
14019             break;
14020         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
14021         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
14022           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
14023             break;
14024         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
14025           *invlist = add_cp_to_invlist(*invlist,
14026                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
14027             break;
14028         case LATIN_SMALL_LETTER_SHARP_S:
14029           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
14030             break;
14031         default:
14032             /* Use deprecated warning to increase the chances of this being
14033              * output */
14034             if (PASS2) {
14035                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
14036             }
14037             break;
14038     }
14039 }
14040
14041 STATIC AV *
14042 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
14043 {
14044     /* This adds the string scalar <multi_string> to the array
14045      * <multi_char_matches>.  <multi_string> is known to have exactly
14046      * <cp_count> code points in it.  This is used when constructing a
14047      * bracketed character class and we find something that needs to match more
14048      * than a single character.
14049      *
14050      * <multi_char_matches> is actually an array of arrays.  Each top-level
14051      * element is an array that contains all the strings known so far that are
14052      * the same length.  And that length (in number of code points) is the same
14053      * as the index of the top-level array.  Hence, the [2] element is an
14054      * array, each element thereof is a string containing TWO code points;
14055      * while element [3] is for strings of THREE characters, and so on.  Since
14056      * this is for multi-char strings there can never be a [0] nor [1] element.
14057      *
14058      * When we rewrite the character class below, we will do so such that the
14059      * longest strings are written first, so that it prefers the longest
14060      * matching strings first.  This is done even if it turns out that any
14061      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
14062      * Christiansen has agreed that this is ok.  This makes the test for the
14063      * ligature 'ffi' come before the test for 'ff', for example */
14064
14065     AV* this_array;
14066     AV** this_array_ptr;
14067
14068     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
14069
14070     if (! multi_char_matches) {
14071         multi_char_matches = newAV();
14072     }
14073
14074     if (av_exists(multi_char_matches, cp_count)) {
14075         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
14076         this_array = *this_array_ptr;
14077     }
14078     else {
14079         this_array = newAV();
14080         av_store(multi_char_matches, cp_count,
14081                  (SV*) this_array);
14082     }
14083     av_push(this_array, multi_string);
14084
14085     return multi_char_matches;
14086 }
14087
14088 /* The names of properties whose definitions are not known at compile time are
14089  * stored in this SV, after a constant heading.  So if the length has been
14090  * changed since initialization, then there is a run-time definition. */
14091 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
14092                                         (SvCUR(listsv) != initial_listsv_len)
14093
14094 STATIC regnode *
14095 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
14096                  const bool stop_at_1,  /* Just parse the next thing, don't
14097                                            look for a full character class */
14098                  bool allow_multi_folds,
14099                  const bool silence_non_portable,   /* Don't output warnings
14100                                                        about too large
14101                                                        characters */
14102                  const bool strict,
14103                  SV** ret_invlist  /* Return an inversion list, not a node */
14104           )
14105 {
14106     /* parse a bracketed class specification.  Most of these will produce an
14107      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
14108      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
14109      * under /i with multi-character folds: it will be rewritten following the
14110      * paradigm of this example, where the <multi-fold>s are characters which
14111      * fold to multiple character sequences:
14112      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
14113      * gets effectively rewritten as:
14114      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
14115      * reg() gets called (recursively) on the rewritten version, and this
14116      * function will return what it constructs.  (Actually the <multi-fold>s
14117      * aren't physically removed from the [abcdefghi], it's just that they are
14118      * ignored in the recursion by means of a flag:
14119      * <RExC_in_multi_char_class>.)
14120      *
14121      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
14122      * characters, with the corresponding bit set if that character is in the
14123      * list.  For characters above this, a range list or swash is used.  There
14124      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
14125      * determinable at compile time
14126      *
14127      * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
14128      * to be restarted.  This can only happen if ret_invlist is non-NULL.
14129      */
14130
14131     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
14132     IV range = 0;
14133     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
14134     regnode *ret;
14135     STRLEN numlen;
14136     IV namedclass = OOB_NAMEDCLASS;
14137     char *rangebegin = NULL;
14138     bool need_class = 0;
14139     SV *listsv = NULL;
14140     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
14141                                       than just initialized.  */
14142     SV* properties = NULL;    /* Code points that match \p{} \P{} */
14143     SV* posixes = NULL;     /* Code points that match classes like [:word:],
14144                                extended beyond the Latin1 range.  These have to
14145                                be kept separate from other code points for much
14146                                of this function because their handling  is
14147                                different under /i, and for most classes under
14148                                /d as well */
14149     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
14150                                separate for a while from the non-complemented
14151                                versions because of complications with /d
14152                                matching */
14153     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
14154                                   treated more simply than the general case,
14155                                   leading to less compilation and execution
14156                                   work */
14157     UV element_count = 0;   /* Number of distinct elements in the class.
14158                                Optimizations may be possible if this is tiny */
14159     AV * multi_char_matches = NULL; /* Code points that fold to more than one
14160                                        character; used under /i */
14161     UV n;
14162     char * stop_ptr = RExC_end;    /* where to stop parsing */
14163     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
14164                                                    space? */
14165
14166     /* Unicode properties are stored in a swash; this holds the current one
14167      * being parsed.  If this swash is the only above-latin1 component of the
14168      * character class, an optimization is to pass it directly on to the
14169      * execution engine.  Otherwise, it is set to NULL to indicate that there
14170      * are other things in the class that have to be dealt with at execution
14171      * time */
14172     SV* swash = NULL;           /* Code points that match \p{} \P{} */
14173
14174     /* Set if a component of this character class is user-defined; just passed
14175      * on to the engine */
14176     bool has_user_defined_property = FALSE;
14177
14178     /* inversion list of code points this node matches only when the target
14179      * string is in UTF-8.  (Because is under /d) */
14180     SV* depends_list = NULL;
14181
14182     /* Inversion list of code points this node matches regardless of things
14183      * like locale, folding, utf8ness of the target string */
14184     SV* cp_list = NULL;
14185
14186     /* Like cp_list, but code points on this list need to be checked for things
14187      * that fold to/from them under /i */
14188     SV* cp_foldable_list = NULL;
14189
14190     /* Like cp_list, but code points on this list are valid only when the
14191      * runtime locale is UTF-8 */
14192     SV* only_utf8_locale_list = NULL;
14193
14194     /* In a range, if one of the endpoints is non-character-set portable,
14195      * meaning that it hard-codes a code point that may mean a different
14196      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
14197      * mnemonic '\t' which each mean the same character no matter which
14198      * character set the platform is on. */
14199     unsigned int non_portable_endpoint = 0;
14200
14201     /* Is the range unicode? which means on a platform that isn't 1-1 native
14202      * to Unicode (i.e. non-ASCII), each code point in it should be considered
14203      * to be a Unicode value.  */
14204     bool unicode_range = FALSE;
14205     bool invert = FALSE;    /* Is this class to be complemented */
14206
14207     bool warn_super = ALWAYS_WARN_SUPER;
14208
14209     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
14210         case we need to change the emitted regop to an EXACT. */
14211     const char * orig_parse = RExC_parse;
14212     const SSize_t orig_size = RExC_size;
14213     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
14214     GET_RE_DEBUG_FLAGS_DECL;
14215
14216     PERL_ARGS_ASSERT_REGCLASS;
14217 #ifndef DEBUGGING
14218     PERL_UNUSED_ARG(depth);
14219 #endif
14220
14221     DEBUG_PARSE("clas");
14222
14223     /* Assume we are going to generate an ANYOF node. */
14224     ret = reganode(pRExC_state,
14225                    (LOC)
14226                     ? ANYOFL
14227                     : ANYOF,
14228                    0);
14229
14230     if (SIZE_ONLY) {
14231         RExC_size += ANYOF_SKIP;
14232         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
14233     }
14234     else {
14235         ANYOF_FLAGS(ret) = 0;
14236
14237         RExC_emit += ANYOF_SKIP;
14238         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
14239         initial_listsv_len = SvCUR(listsv);
14240         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
14241     }
14242
14243     if (skip_white) {
14244         RExC_parse = regpatws(pRExC_state, RExC_parse,
14245                               FALSE /* means don't recognize comments */ );
14246     }
14247
14248     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
14249         RExC_parse++;
14250         invert = TRUE;
14251         allow_multi_folds = FALSE;
14252         MARK_NAUGHTY(1);
14253         if (skip_white) {
14254             RExC_parse = regpatws(pRExC_state, RExC_parse,
14255                                   FALSE /* means don't recognize comments */ );
14256         }
14257     }
14258
14259     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
14260     if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
14261         const char *s = RExC_parse;
14262         const char  c = *s++;
14263
14264         if (*s == '^') {
14265             s++;
14266         }
14267         while (isWORDCHAR(*s))
14268             s++;
14269         if (*s && c == *s && s[1] == ']') {
14270             SAVEFREESV(RExC_rx_sv);
14271             ckWARN3reg(s+2,
14272                        "POSIX syntax [%c %c] belongs inside character classes",
14273                        c, c);
14274             (void)ReREFCNT_inc(RExC_rx_sv);
14275         }
14276     }
14277
14278     /* If the caller wants us to just parse a single element, accomplish this
14279      * by faking the loop ending condition */
14280     if (stop_at_1 && RExC_end > RExC_parse) {
14281         stop_ptr = RExC_parse + 1;
14282     }
14283
14284     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
14285     if (UCHARAT(RExC_parse) == ']')
14286         goto charclassloop;
14287
14288     while (1) {
14289         if  (RExC_parse >= stop_ptr) {
14290             break;
14291         }
14292
14293         if (skip_white) {
14294             RExC_parse = regpatws(pRExC_state, RExC_parse,
14295                                   FALSE /* means don't recognize comments */ );
14296         }
14297
14298         if  (UCHARAT(RExC_parse) == ']') {
14299             break;
14300         }
14301
14302       charclassloop:
14303
14304         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
14305         save_value = value;
14306         save_prevvalue = prevvalue;
14307
14308         if (!range) {
14309             rangebegin = RExC_parse;
14310             element_count++;
14311             non_portable_endpoint = 0;
14312         }
14313         if (UTF) {
14314             value = utf8n_to_uvchr((U8*)RExC_parse,
14315                                    RExC_end - RExC_parse,
14316                                    &numlen, UTF8_ALLOW_DEFAULT);
14317             RExC_parse += numlen;
14318         }
14319         else
14320             value = UCHARAT(RExC_parse++);
14321
14322         if (value == '['
14323             && RExC_parse < RExC_end
14324             && POSIXCC(UCHARAT(RExC_parse)))
14325         {
14326             namedclass = regpposixcc(pRExC_state, value, strict);
14327         }
14328         else if (value == '\\') {
14329             /* Is a backslash; get the code point of the char after it */
14330             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
14331                 value = utf8n_to_uvchr((U8*)RExC_parse,
14332                                    RExC_end - RExC_parse,
14333                                    &numlen, UTF8_ALLOW_DEFAULT);
14334                 RExC_parse += numlen;
14335             }
14336             else
14337                 value = UCHARAT(RExC_parse++);
14338
14339             /* Some compilers cannot handle switching on 64-bit integer
14340              * values, therefore value cannot be an UV.  Yes, this will
14341              * be a problem later if we want switch on Unicode.
14342              * A similar issue a little bit later when switching on
14343              * namedclass. --jhi */
14344
14345             /* If the \ is escaping white space when white space is being
14346              * skipped, it means that that white space is wanted literally, and
14347              * is already in 'value'.  Otherwise, need to translate the escape
14348              * into what it signifies. */
14349             if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
14350
14351             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
14352             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
14353             case 's':   namedclass = ANYOF_SPACE;       break;
14354             case 'S':   namedclass = ANYOF_NSPACE;      break;
14355             case 'd':   namedclass = ANYOF_DIGIT;       break;
14356             case 'D':   namedclass = ANYOF_NDIGIT;      break;
14357             case 'v':   namedclass = ANYOF_VERTWS;      break;
14358             case 'V':   namedclass = ANYOF_NVERTWS;     break;
14359             case 'h':   namedclass = ANYOF_HORIZWS;     break;
14360             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
14361             case 'N':  /* Handle \N{NAME} in class */
14362                 {
14363                     const char * const backslash_N_beg = RExC_parse - 2;
14364                     int cp_count;
14365
14366                     if (! grok_bslash_N(pRExC_state,
14367                                         NULL,      /* No regnode */
14368                                         &value,    /* Yes single value */
14369                                         &cp_count, /* Multiple code pt count */
14370                                         flagp,
14371                                         depth)
14372                     ) {
14373
14374                         if (*flagp & RESTART_UTF8)
14375                             FAIL("panic: grok_bslash_N set RESTART_UTF8");
14376
14377                         if (cp_count < 0) {
14378                             vFAIL("\\N in a character class must be a named character: \\N{...}");
14379                         }
14380                         else if (cp_count == 0) {
14381                             if (strict) {
14382                                 RExC_parse++;   /* Position after the "}" */
14383                                 vFAIL("Zero length \\N{}");
14384                             }
14385                             else if (PASS2) {
14386                                 ckWARNreg(RExC_parse,
14387                                         "Ignoring zero length \\N{} in character class");
14388                             }
14389                         }
14390                         else { /* cp_count > 1 */
14391                             if (! RExC_in_multi_char_class) {
14392                                 if (invert || range || *RExC_parse == '-') {
14393                                     if (strict) {
14394                                         RExC_parse--;
14395                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
14396                                     }
14397                                     else if (PASS2) {
14398                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
14399                                     }
14400                                     break; /* <value> contains the first code
14401                                               point. Drop out of the switch to
14402                                               process it */
14403                                 }
14404                                 else {
14405                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
14406                                                  RExC_parse - backslash_N_beg);
14407                                     multi_char_matches
14408                                         = add_multi_match(multi_char_matches,
14409                                                           multi_char_N,
14410                                                           cp_count);
14411                                 }
14412                             }
14413                         } /* End of cp_count != 1 */
14414
14415                         /* This element should not be processed further in this
14416                          * class */
14417                         element_count--;
14418                         value = save_value;
14419                         prevvalue = save_prevvalue;
14420                         continue;   /* Back to top of loop to get next char */
14421                     }
14422
14423                     /* Here, is a single code point, and <value> contains it */
14424                     unicode_range = TRUE;   /* \N{} are Unicode */
14425                 }
14426                 break;
14427             case 'p':
14428             case 'P':
14429                 {
14430                 char *e;
14431
14432                 /* We will handle any undefined properties ourselves */
14433                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
14434                                        /* And we actually would prefer to get
14435                                         * the straight inversion list of the
14436                                         * swash, since we will be accessing it
14437                                         * anyway, to save a little time */
14438                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
14439
14440                 if (RExC_parse >= RExC_end)
14441                     vFAIL2("Empty \\%c{}", (U8)value);
14442                 if (*RExC_parse == '{') {
14443                     const U8 c = (U8)value;
14444                     e = strchr(RExC_parse++, '}');
14445                     if (!e)
14446                         vFAIL2("Missing right brace on \\%c{}", c);
14447                     while (isSPACE(*RExC_parse))
14448                         RExC_parse++;
14449                     if (e == RExC_parse)
14450                         vFAIL2("Empty \\%c{}", c);
14451                     n = e - RExC_parse;
14452                     while (isSPACE(*(RExC_parse + n - 1)))
14453                         n--;
14454                 }
14455                 else {
14456                     e = RExC_parse;
14457                     n = 1;
14458                 }
14459                 if (!SIZE_ONLY) {
14460                     SV* invlist;
14461                     char* name;
14462
14463                     if (UCHARAT(RExC_parse) == '^') {
14464                          RExC_parse++;
14465                          n--;
14466                          /* toggle.  (The rhs xor gets the single bit that
14467                           * differs between P and p; the other xor inverts just
14468                           * that bit) */
14469                          value ^= 'P' ^ 'p';
14470
14471                          while (isSPACE(*RExC_parse)) {
14472                               RExC_parse++;
14473                               n--;
14474                          }
14475                     }
14476                     /* Try to get the definition of the property into
14477                      * <invlist>.  If /i is in effect, the effective property
14478                      * will have its name be <__NAME_i>.  The design is
14479                      * discussed in commit
14480                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
14481                     name = savepv(Perl_form(aTHX_
14482                                           "%s%.*s%s\n",
14483                                           (FOLD) ? "__" : "",
14484                                           (int)n,
14485                                           RExC_parse,
14486                                           (FOLD) ? "_i" : ""
14487                                 ));
14488
14489                     /* Look up the property name, and get its swash and
14490                      * inversion list, if the property is found  */
14491                     if (swash) {
14492                         SvREFCNT_dec_NN(swash);
14493                     }
14494                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
14495                                              1, /* binary */
14496                                              0, /* not tr/// */
14497                                              NULL, /* No inversion list */
14498                                              &swash_init_flags
14499                                             );
14500                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
14501                         HV* curpkg = (IN_PERL_COMPILETIME)
14502                                       ? PL_curstash
14503                                       : CopSTASH(PL_curcop);
14504                         if (swash) {
14505                             SvREFCNT_dec_NN(swash);
14506                             swash = NULL;
14507                         }
14508
14509                         /* Here didn't find it.  It could be a user-defined
14510                          * property that will be available at run-time.  If we
14511                          * accept only compile-time properties, is an error;
14512                          * otherwise add it to the list for run-time look up */
14513                         if (ret_invlist) {
14514                             RExC_parse = e + 1;
14515                             vFAIL2utf8f(
14516                                 "Property '%"UTF8f"' is unknown",
14517                                 UTF8fARG(UTF, n, name));
14518                         }
14519
14520                         /* If the property name doesn't already have a package
14521                          * name, add the current one to it so that it can be
14522                          * referred to outside it. [perl #121777] */
14523                         if (curpkg && ! instr(name, "::")) {
14524                             char* pkgname = HvNAME(curpkg);
14525                             if (strNE(pkgname, "main")) {
14526                                 char* full_name = Perl_form(aTHX_
14527                                                             "%s::%s",
14528                                                             pkgname,
14529                                                             name);
14530                                 n = strlen(full_name);
14531                                 Safefree(name);
14532                                 name = savepvn(full_name, n);
14533                             }
14534                         }
14535                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%"UTF8f"\n",
14536                                         (value == 'p' ? '+' : '!'),
14537                                         UTF8fARG(UTF, n, name));
14538                         has_user_defined_property = TRUE;
14539
14540                         /* We don't know yet, so have to assume that the
14541                          * property could match something in the Latin1 range,
14542                          * hence something that isn't utf8.  Note that this
14543                          * would cause things in <depends_list> to match
14544                          * inappropriately, except that any \p{}, including
14545                          * this one forces Unicode semantics, which means there
14546                          * is no <depends_list> */
14547                         ANYOF_FLAGS(ret)
14548                                       |= ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES;
14549                     }
14550                     else {
14551
14552                         /* Here, did get the swash and its inversion list.  If
14553                          * the swash is from a user-defined property, then this
14554                          * whole character class should be regarded as such */
14555                         if (swash_init_flags
14556                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
14557                         {
14558                             has_user_defined_property = TRUE;
14559                         }
14560                         else if
14561                             /* We warn on matching an above-Unicode code point
14562                              * if the match would return true, except don't
14563                              * warn for \p{All}, which has exactly one element
14564                              * = 0 */
14565                             (_invlist_contains_cp(invlist, 0x110000)
14566                                 && (! (_invlist_len(invlist) == 1
14567                                        && *invlist_array(invlist) == 0)))
14568                         {
14569                             warn_super = TRUE;
14570                         }
14571
14572
14573                         /* Invert if asking for the complement */
14574                         if (value == 'P') {
14575                             _invlist_union_complement_2nd(properties,
14576                                                           invlist,
14577                                                           &properties);
14578
14579                             /* The swash can't be used as-is, because we've
14580                              * inverted things; delay removing it to here after
14581                              * have copied its invlist above */
14582                             SvREFCNT_dec_NN(swash);
14583                             swash = NULL;
14584                         }
14585                         else {
14586                             _invlist_union(properties, invlist, &properties);
14587                         }
14588                     }
14589                     Safefree(name);
14590                 }
14591                 RExC_parse = e + 1;
14592                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
14593                                                 named */
14594
14595                 /* \p means they want Unicode semantics */
14596                 RExC_uni_semantics = 1;
14597                 }
14598                 break;
14599             case 'n':   value = '\n';                   break;
14600             case 'r':   value = '\r';                   break;
14601             case 't':   value = '\t';                   break;
14602             case 'f':   value = '\f';                   break;
14603             case 'b':   value = '\b';                   break;
14604             case 'e':   value = ESC_NATIVE;             break;
14605             case 'a':   value = '\a';                   break;
14606             case 'o':
14607                 RExC_parse--;   /* function expects to be pointed at the 'o' */
14608                 {
14609                     const char* error_msg;
14610                     bool valid = grok_bslash_o(&RExC_parse,
14611                                                &value,
14612                                                &error_msg,
14613                                                PASS2,   /* warnings only in
14614                                                            pass 2 */
14615                                                strict,
14616                                                silence_non_portable,
14617                                                UTF);
14618                     if (! valid) {
14619                         vFAIL(error_msg);
14620                     }
14621                 }
14622                 non_portable_endpoint++;
14623                 if (IN_ENCODING && value < 0x100) {
14624                     goto recode_encoding;
14625                 }
14626                 break;
14627             case 'x':
14628                 RExC_parse--;   /* function expects to be pointed at the 'x' */
14629                 {
14630                     const char* error_msg;
14631                     bool valid = grok_bslash_x(&RExC_parse,
14632                                                &value,
14633                                                &error_msg,
14634                                                PASS2, /* Output warnings */
14635                                                strict,
14636                                                silence_non_portable,
14637                                                UTF);
14638                     if (! valid) {
14639                         vFAIL(error_msg);
14640                     }
14641                 }
14642                 non_portable_endpoint++;
14643                 if (IN_ENCODING && value < 0x100)
14644                     goto recode_encoding;
14645                 break;
14646             case 'c':
14647                 value = grok_bslash_c(*RExC_parse++, PASS2);
14648                 non_portable_endpoint++;
14649                 break;
14650             case '0': case '1': case '2': case '3': case '4':
14651             case '5': case '6': case '7':
14652                 {
14653                     /* Take 1-3 octal digits */
14654                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
14655                     numlen = (strict) ? 4 : 3;
14656                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
14657                     RExC_parse += numlen;
14658                     if (numlen != 3) {
14659                         if (strict) {
14660                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
14661                             vFAIL("Need exactly 3 octal digits");
14662                         }
14663                         else if (! SIZE_ONLY /* like \08, \178 */
14664                                  && numlen < 3
14665                                  && RExC_parse < RExC_end
14666                                  && isDIGIT(*RExC_parse)
14667                                  && ckWARN(WARN_REGEXP))
14668                         {
14669                             SAVEFREESV(RExC_rx_sv);
14670                             reg_warn_non_literal_string(
14671                                  RExC_parse + 1,
14672                                  form_short_octal_warning(RExC_parse, numlen));
14673                             (void)ReREFCNT_inc(RExC_rx_sv);
14674                         }
14675                     }
14676                     non_portable_endpoint++;
14677                     if (IN_ENCODING && value < 0x100)
14678                         goto recode_encoding;
14679                     break;
14680                 }
14681               recode_encoding:
14682                 if (! RExC_override_recoding) {
14683                     SV* enc = _get_encoding();
14684                     value = reg_recode((const char)(U8)value, &enc);
14685                     if (!enc) {
14686                         if (strict) {
14687                             vFAIL("Invalid escape in the specified encoding");
14688                         }
14689                         else if (PASS2) {
14690                             ckWARNreg(RExC_parse,
14691                                   "Invalid escape in the specified encoding");
14692                         }
14693                     }
14694                     break;
14695                 }
14696             default:
14697                 /* Allow \_ to not give an error */
14698                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
14699                     if (strict) {
14700                         vFAIL2("Unrecognized escape \\%c in character class",
14701                                (int)value);
14702                     }
14703                     else {
14704                         SAVEFREESV(RExC_rx_sv);
14705                         ckWARN2reg(RExC_parse,
14706                             "Unrecognized escape \\%c in character class passed through",
14707                             (int)value);
14708                         (void)ReREFCNT_inc(RExC_rx_sv);
14709                     }
14710                 }
14711                 break;
14712             }   /* End of switch on char following backslash */
14713         } /* end of handling backslash escape sequences */
14714
14715         /* Here, we have the current token in 'value' */
14716
14717         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
14718             U8 classnum;
14719
14720             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
14721              * literal, as is the character that began the false range, i.e.
14722              * the 'a' in the examples */
14723             if (range) {
14724                 if (!SIZE_ONLY) {
14725                     const int w = (RExC_parse >= rangebegin)
14726                                   ? RExC_parse - rangebegin
14727                                   : 0;
14728                     if (strict) {
14729                         vFAIL2utf8f(
14730                             "False [] range \"%"UTF8f"\"",
14731                             UTF8fARG(UTF, w, rangebegin));
14732                     }
14733                     else {
14734                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
14735                         ckWARN2reg(RExC_parse,
14736                             "False [] range \"%"UTF8f"\"",
14737                             UTF8fARG(UTF, w, rangebegin));
14738                         (void)ReREFCNT_inc(RExC_rx_sv);
14739                         cp_list = add_cp_to_invlist(cp_list, '-');
14740                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
14741                                                              prevvalue);
14742                     }
14743                 }
14744
14745                 range = 0; /* this was not a true range */
14746                 element_count += 2; /* So counts for three values */
14747             }
14748
14749             classnum = namedclass_to_classnum(namedclass);
14750
14751             if (LOC && namedclass < ANYOF_POSIXL_MAX
14752 #ifndef HAS_ISASCII
14753                 && classnum != _CC_ASCII
14754 #endif
14755             ) {
14756                 /* What the Posix classes (like \w, [:space:]) match in locale
14757                  * isn't knowable under locale until actual match time.  Room
14758                  * must be reserved (one time per outer bracketed class) to
14759                  * store such classes.  The space will contain a bit for each
14760                  * named class that is to be matched against.  This isn't
14761                  * needed for \p{} and pseudo-classes, as they are not affected
14762                  * by locale, and hence are dealt with separately */
14763                 if (! need_class) {
14764                     need_class = 1;
14765                     if (SIZE_ONLY) {
14766                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
14767                     }
14768                     else {
14769                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
14770                     }
14771                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
14772                     ANYOF_POSIXL_ZERO(ret);
14773                 }
14774
14775                 /* Coverity thinks it is possible for this to be negative; both
14776                  * jhi and khw think it's not, but be safer */
14777                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
14778                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
14779
14780                 /* See if it already matches the complement of this POSIX
14781                  * class */
14782                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
14783                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
14784                                                             ? -1
14785                                                             : 1)))
14786                 {
14787                     posixl_matches_all = TRUE;
14788                     break;  /* No need to continue.  Since it matches both
14789                                e.g., \w and \W, it matches everything, and the
14790                                bracketed class can be optimized into qr/./s */
14791                 }
14792
14793                 /* Add this class to those that should be checked at runtime */
14794                 ANYOF_POSIXL_SET(ret, namedclass);
14795
14796                 /* The above-Latin1 characters are not subject to locale rules.
14797                  * Just add them, in the second pass, to the
14798                  * unconditionally-matched list */
14799                 if (! SIZE_ONLY) {
14800                     SV* scratch_list = NULL;
14801
14802                     /* Get the list of the above-Latin1 code points this
14803                      * matches */
14804                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
14805                                           PL_XPosix_ptrs[classnum],
14806
14807                                           /* Odd numbers are complements, like
14808                                            * NDIGIT, NASCII, ... */
14809                                           namedclass % 2 != 0,
14810                                           &scratch_list);
14811                     /* Checking if 'cp_list' is NULL first saves an extra
14812                      * clone.  Its reference count will be decremented at the
14813                      * next union, etc, or if this is the only instance, at the
14814                      * end of the routine */
14815                     if (! cp_list) {
14816                         cp_list = scratch_list;
14817                     }
14818                     else {
14819                         _invlist_union(cp_list, scratch_list, &cp_list);
14820                         SvREFCNT_dec_NN(scratch_list);
14821                     }
14822                     continue;   /* Go get next character */
14823                 }
14824             }
14825             else if (! SIZE_ONLY) {
14826
14827                 /* Here, not in pass1 (in that pass we skip calculating the
14828                  * contents of this class), and is /l, or is a POSIX class for
14829                  * which /l doesn't matter (or is a Unicode property, which is
14830                  * skipped here). */
14831                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
14832                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
14833
14834                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
14835                          * nor /l make a difference in what these match,
14836                          * therefore we just add what they match to cp_list. */
14837                         if (classnum != _CC_VERTSPACE) {
14838                             assert(   namedclass == ANYOF_HORIZWS
14839                                    || namedclass == ANYOF_NHORIZWS);
14840
14841                             /* It turns out that \h is just a synonym for
14842                              * XPosixBlank */
14843                             classnum = _CC_BLANK;
14844                         }
14845
14846                         _invlist_union_maybe_complement_2nd(
14847                                 cp_list,
14848                                 PL_XPosix_ptrs[classnum],
14849                                 namedclass % 2 != 0,    /* Complement if odd
14850                                                           (NHORIZWS, NVERTWS)
14851                                                         */
14852                                 &cp_list);
14853                     }
14854                 }
14855                 else if (UNI_SEMANTICS
14856                         || classnum == _CC_ASCII
14857                         || (DEPENDS_SEMANTICS && (classnum == _CC_DIGIT
14858                                                   || classnum == _CC_XDIGIT)))
14859                 {
14860                     /* We usually have to worry about /d and /a affecting what
14861                      * POSIX classes match, with special code needed for /d
14862                      * because we won't know until runtime what all matches.
14863                      * But there is no extra work needed under /u, and
14864                      * [:ascii:] is unaffected by /a and /d; and :digit: and
14865                      * :xdigit: don't have runtime differences under /d.  So we
14866                      * can special case these, and avoid some extra work below,
14867                      * and at runtime. */
14868                     _invlist_union_maybe_complement_2nd(
14869                                                      simple_posixes,
14870                                                      PL_XPosix_ptrs[classnum],
14871                                                      namedclass % 2 != 0,
14872                                                      &simple_posixes);
14873                 }
14874                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
14875                            complement and use nposixes */
14876                     SV** posixes_ptr = namedclass % 2 == 0
14877                                        ? &posixes
14878                                        : &nposixes;
14879                     _invlist_union_maybe_complement_2nd(
14880                                                      *posixes_ptr,
14881                                                      PL_XPosix_ptrs[classnum],
14882                                                      namedclass % 2 != 0,
14883                                                      posixes_ptr);
14884                 }
14885             }
14886         } /* end of namedclass \blah */
14887
14888         if (skip_white) {
14889             RExC_parse = regpatws(pRExC_state, RExC_parse,
14890                                 FALSE /* means don't recognize comments */ );
14891         }
14892
14893         /* If 'range' is set, 'value' is the ending of a range--check its
14894          * validity.  (If value isn't a single code point in the case of a
14895          * range, we should have figured that out above in the code that
14896          * catches false ranges).  Later, we will handle each individual code
14897          * point in the range.  If 'range' isn't set, this could be the
14898          * beginning of a range, so check for that by looking ahead to see if
14899          * the next real character to be processed is the range indicator--the
14900          * minus sign */
14901
14902         if (range) {
14903 #ifdef EBCDIC
14904             /* For unicode ranges, we have to test that the Unicode as opposed
14905              * to the native values are not decreasing.  (Above 255, there is
14906              * no difference between native and Unicode) */
14907             if (unicode_range && prevvalue < 255 && value < 255) {
14908                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
14909                     goto backwards_range;
14910                 }
14911             }
14912             else
14913 #endif
14914             if (prevvalue > value) /* b-a */ {
14915                 int w;
14916 #ifdef EBCDIC
14917               backwards_range:
14918 #endif
14919                 w = RExC_parse - rangebegin;
14920                 vFAIL2utf8f(
14921                     "Invalid [] range \"%"UTF8f"\"",
14922                     UTF8fARG(UTF, w, rangebegin));
14923                 NOT_REACHED; /* NOTREACHED */
14924             }
14925         }
14926         else {
14927             prevvalue = value; /* save the beginning of the potential range */
14928             if (! stop_at_1     /* Can't be a range if parsing just one thing */
14929                 && *RExC_parse == '-')
14930             {
14931                 char* next_char_ptr = RExC_parse + 1;
14932                 if (skip_white) {   /* Get the next real char after the '-' */
14933                     next_char_ptr = regpatws(pRExC_state,
14934                                              RExC_parse + 1,
14935                                              FALSE); /* means don't recognize
14936                                                         comments */
14937                 }
14938
14939                 /* If the '-' is at the end of the class (just before the ']',
14940                  * it is a literal minus; otherwise it is a range */
14941                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
14942                     RExC_parse = next_char_ptr;
14943
14944                     /* a bad range like \w-, [:word:]- ? */
14945                     if (namedclass > OOB_NAMEDCLASS) {
14946                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
14947                             const int w = RExC_parse >= rangebegin
14948                                           ?  RExC_parse - rangebegin
14949                                           : 0;
14950                             if (strict) {
14951                                 vFAIL4("False [] range \"%*.*s\"",
14952                                     w, w, rangebegin);
14953                             }
14954                             else if (PASS2) {
14955                                 vWARN4(RExC_parse,
14956                                     "False [] range \"%*.*s\"",
14957                                     w, w, rangebegin);
14958                             }
14959                         }
14960                         if (!SIZE_ONLY) {
14961                             cp_list = add_cp_to_invlist(cp_list, '-');
14962                         }
14963                         element_count++;
14964                     } else
14965                         range = 1;      /* yeah, it's a range! */
14966                     continue;   /* but do it the next time */
14967                 }
14968             }
14969         }
14970
14971         if (namedclass > OOB_NAMEDCLASS) {
14972             continue;
14973         }
14974
14975         /* Here, we have a single value this time through the loop, and
14976          * <prevvalue> is the beginning of the range, if any; or <value> if
14977          * not. */
14978
14979         /* non-Latin1 code point implies unicode semantics.  Must be set in
14980          * pass1 so is there for the whole of pass 2 */
14981         if (value > 255) {
14982             RExC_uni_semantics = 1;
14983         }
14984
14985         /* Ready to process either the single value, or the completed range.
14986          * For single-valued non-inverted ranges, we consider the possibility
14987          * of multi-char folds.  (We made a conscious decision to not do this
14988          * for the other cases because it can often lead to non-intuitive
14989          * results.  For example, you have the peculiar case that:
14990          *  "s s" =~ /^[^\xDF]+$/i => Y
14991          *  "ss"  =~ /^[^\xDF]+$/i => N
14992          *
14993          * See [perl #89750] */
14994         if (FOLD && allow_multi_folds && value == prevvalue) {
14995             if (value == LATIN_SMALL_LETTER_SHARP_S
14996                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
14997                                                         value)))
14998             {
14999                 /* Here <value> is indeed a multi-char fold.  Get what it is */
15000
15001                 U8 foldbuf[UTF8_MAXBYTES_CASE];
15002                 STRLEN foldlen;
15003
15004                 UV folded = _to_uni_fold_flags(
15005                                 value,
15006                                 foldbuf,
15007                                 &foldlen,
15008                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
15009                                                    ? FOLD_FLAGS_NOMIX_ASCII
15010                                                    : 0)
15011                                 );
15012
15013                 /* Here, <folded> should be the first character of the
15014                  * multi-char fold of <value>, with <foldbuf> containing the
15015                  * whole thing.  But, if this fold is not allowed (because of
15016                  * the flags), <fold> will be the same as <value>, and should
15017                  * be processed like any other character, so skip the special
15018                  * handling */
15019                 if (folded != value) {
15020
15021                     /* Skip if we are recursed, currently parsing the class
15022                      * again.  Otherwise add this character to the list of
15023                      * multi-char folds. */
15024                     if (! RExC_in_multi_char_class) {
15025                         STRLEN cp_count = utf8_length(foldbuf,
15026                                                       foldbuf + foldlen);
15027                         SV* multi_fold = sv_2mortal(newSVpvs(""));
15028
15029                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
15030
15031                         multi_char_matches
15032                                         = add_multi_match(multi_char_matches,
15033                                                           multi_fold,
15034                                                           cp_count);
15035
15036                     }
15037
15038                     /* This element should not be processed further in this
15039                      * class */
15040                     element_count--;
15041                     value = save_value;
15042                     prevvalue = save_prevvalue;
15043                     continue;
15044                 }
15045             }
15046         }
15047
15048         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
15049             if (range) {
15050
15051                 /* If the range starts above 255, everything is portable and
15052                  * likely to be so for any forseeable character set, so don't
15053                  * warn. */
15054                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
15055                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
15056                 }
15057                 else if (prevvalue != value) {
15058
15059                     /* Under strict, ranges that stop and/or end in an ASCII
15060                      * printable should have each end point be a portable value
15061                      * for it (preferably like 'A', but we don't warn if it is
15062                      * a (portable) Unicode name or code point), and the range
15063                      * must be be all digits or all letters of the same case.
15064                      * Otherwise, the range is non-portable and unclear as to
15065                      * what it contains */
15066                     if ((isPRINT_A(prevvalue) || isPRINT_A(value))
15067                         && (non_portable_endpoint
15068                             || ! ((isDIGIT_A(prevvalue) && isDIGIT_A(value))
15069                                    || (isLOWER_A(prevvalue) && isLOWER_A(value))
15070                                    || (isUPPER_A(prevvalue) && isUPPER_A(value)))))
15071                     {
15072                         vWARN(RExC_parse, "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\"");
15073                     }
15074                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
15075
15076                         /* But the nature of Unicode and languages mean we
15077                          * can't do the same checks for above-ASCII ranges,
15078                          * except in the case of digit ones.  These should
15079                          * contain only digits from the same group of 10.  The
15080                          * ASCII case is handled just above.  0x660 is the
15081                          * first digit character beyond ASCII.  Hence here, the
15082                          * range could be a range of digits.  Find out.  */
15083                         IV index_start = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
15084                                                          prevvalue);
15085                         IV index_final = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
15086                                                          value);
15087
15088                         /* If the range start and final points are in the same
15089                          * inversion list element, it means that either both
15090                          * are not digits, or both are digits in a consecutive
15091                          * sequence of digits.  (So far, Unicode has kept all
15092                          * such sequences as distinct groups of 10, but assert
15093                          * to make sure).  If the end points are not in the
15094                          * same element, neither should be a digit. */
15095                         if (index_start == index_final) {
15096                             assert(! ELEMENT_RANGE_MATCHES_INVLIST(index_start)
15097                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
15098                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
15099                                == 10)
15100                                /* But actually Unicode did have one group of 11
15101                                 * 'digits' in 5.2, so in case we are operating
15102                                 * on that version, let that pass */
15103                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
15104                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
15105                                 == 11
15106                                && invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
15107                                 == 0x19D0)
15108                             );
15109                         }
15110                         else if ((index_start >= 0
15111                                   && ELEMENT_RANGE_MATCHES_INVLIST(index_start))
15112                                  || (index_final >= 0
15113                                      && ELEMENT_RANGE_MATCHES_INVLIST(index_final)))
15114                         {
15115                             vWARN(RExC_parse, "Ranges of digits should be from the same group of 10");
15116                         }
15117                     }
15118                 }
15119             }
15120             if ((! range || prevvalue == value) && non_portable_endpoint) {
15121                 if (isPRINT_A(value)) {
15122                     char literal[3];
15123                     unsigned d = 0;
15124                     if (isBACKSLASHED_PUNCT(value)) {
15125                         literal[d++] = '\\';
15126                     }
15127                     literal[d++] = (char) value;
15128                     literal[d++] = '\0';
15129
15130                     vWARN4(RExC_parse,
15131                            "\"%.*s\" is more clearly written simply as \"%s\"",
15132                            (int) (RExC_parse - rangebegin),
15133                            rangebegin,
15134                            literal
15135                         );
15136                 }
15137                 else if isMNEMONIC_CNTRL(value) {
15138                     vWARN4(RExC_parse,
15139                            "\"%.*s\" is more clearly written simply as \"%s\"",
15140                            (int) (RExC_parse - rangebegin),
15141                            rangebegin,
15142                            cntrl_to_mnemonic((char) value)
15143                         );
15144                 }
15145             }
15146         }
15147
15148         /* Deal with this element of the class */
15149         if (! SIZE_ONLY) {
15150
15151 #ifndef EBCDIC
15152             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
15153                                                      prevvalue, value);
15154 #else
15155             /* On non-ASCII platforms, for ranges that span all of 0..255, and
15156              * ones that don't require special handling, we can just add the
15157              * range like we do for ASCII platforms */
15158             if ((UNLIKELY(prevvalue == 0) && value >= 255)
15159                 || ! (prevvalue < 256
15160                       && (unicode_range
15161                           || (! non_portable_endpoint
15162                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
15163                                   || (isUPPER_A(prevvalue)
15164                                       && isUPPER_A(value)))))))
15165             {
15166                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
15167                                                          prevvalue, value);
15168             }
15169             else {
15170                 /* Here, requires special handling.  This can be because it is
15171                  * a range whose code points are considered to be Unicode, and
15172                  * so must be individually translated into native, or because
15173                  * its a subrange of 'A-Z' or 'a-z' which each aren't
15174                  * contiguous in EBCDIC, but we have defined them to include
15175                  * only the "expected" upper or lower case ASCII alphabetics.
15176                  * Subranges above 255 are the same in native and Unicode, so
15177                  * can be added as a range */
15178                 U8 start = NATIVE_TO_LATIN1(prevvalue);
15179                 unsigned j;
15180                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
15181                 for (j = start; j <= end; j++) {
15182                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
15183                 }
15184                 if (value > 255) {
15185                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
15186                                                              256, value);
15187                 }
15188             }
15189 #endif
15190         }
15191
15192         range = 0; /* this range (if it was one) is done now */
15193     } /* End of loop through all the text within the brackets */
15194
15195     /* If anything in the class expands to more than one character, we have to
15196      * deal with them by building up a substitute parse string, and recursively
15197      * calling reg() on it, instead of proceeding */
15198     if (multi_char_matches) {
15199         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
15200         I32 cp_count;
15201         STRLEN len;
15202         char *save_end = RExC_end;
15203         char *save_parse = RExC_parse;
15204         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
15205                                        a "|" */
15206         I32 reg_flags;
15207
15208         assert(! invert);
15209 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
15210            because too confusing */
15211         if (invert) {
15212             sv_catpv(substitute_parse, "(?:");
15213         }
15214 #endif
15215
15216         /* Look at the longest folds first */
15217         for (cp_count = av_tindex(multi_char_matches); cp_count > 0; cp_count--) {
15218
15219             if (av_exists(multi_char_matches, cp_count)) {
15220                 AV** this_array_ptr;
15221                 SV* this_sequence;
15222
15223                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
15224                                                  cp_count, FALSE);
15225                 while ((this_sequence = av_pop(*this_array_ptr)) !=
15226                                                                 &PL_sv_undef)
15227                 {
15228                     if (! first_time) {
15229                         sv_catpv(substitute_parse, "|");
15230                     }
15231                     first_time = FALSE;
15232
15233                     sv_catpv(substitute_parse, SvPVX(this_sequence));
15234                 }
15235             }
15236         }
15237
15238         /* If the character class contains anything else besides these
15239          * multi-character folds, have to include it in recursive parsing */
15240         if (element_count) {
15241             sv_catpv(substitute_parse, "|[");
15242             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
15243             sv_catpv(substitute_parse, "]");
15244         }
15245
15246         sv_catpv(substitute_parse, ")");
15247 #if 0
15248         if (invert) {
15249             /* This is a way to get the parse to skip forward a whole named
15250              * sequence instead of matching the 2nd character when it fails the
15251              * first */
15252             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
15253         }
15254 #endif
15255
15256         RExC_parse = SvPV(substitute_parse, len);
15257         RExC_end = RExC_parse + len;
15258         RExC_in_multi_char_class = 1;
15259         RExC_override_recoding = 1;
15260         RExC_emit = (regnode *)orig_emit;
15261
15262         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
15263
15264         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
15265
15266         RExC_parse = save_parse;
15267         RExC_end = save_end;
15268         RExC_in_multi_char_class = 0;
15269         RExC_override_recoding = 0;
15270         SvREFCNT_dec_NN(multi_char_matches);
15271         return ret;
15272     }
15273
15274     /* Here, we've gone through the entire class and dealt with multi-char
15275      * folds.  We are now in a position that we can do some checks to see if we
15276      * can optimize this ANYOF node into a simpler one, even in Pass 1.
15277      * Currently we only do two checks:
15278      * 1) is in the unlikely event that the user has specified both, eg. \w and
15279      *    \W under /l, then the class matches everything.  (This optimization
15280      *    is done only to make the optimizer code run later work.)
15281      * 2) if the character class contains only a single element (including a
15282      *    single range), we see if there is an equivalent node for it.
15283      * Other checks are possible */
15284     if (! ret_invlist   /* Can't optimize if returning the constructed
15285                            inversion list */
15286         && (UNLIKELY(posixl_matches_all) || element_count == 1))
15287     {
15288         U8 op = END;
15289         U8 arg = 0;
15290
15291         if (UNLIKELY(posixl_matches_all)) {
15292             op = SANY;
15293         }
15294         else if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like
15295                                                    \w or [:digit:] or \p{foo}
15296                                                  */
15297
15298             /* All named classes are mapped into POSIXish nodes, with its FLAG
15299              * argument giving which class it is */
15300             switch ((I32)namedclass) {
15301                 case ANYOF_UNIPROP:
15302                     break;
15303
15304                 /* These don't depend on the charset modifiers.  They always
15305                  * match under /u rules */
15306                 case ANYOF_NHORIZWS:
15307                 case ANYOF_HORIZWS:
15308                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
15309                     /* FALLTHROUGH */
15310
15311                 case ANYOF_NVERTWS:
15312                 case ANYOF_VERTWS:
15313                     op = POSIXU;
15314                     goto join_posix;
15315
15316                 /* The actual POSIXish node for all the rest depends on the
15317                  * charset modifier.  The ones in the first set depend only on
15318                  * ASCII or, if available on this platform, also locale */
15319                 case ANYOF_ASCII:
15320                 case ANYOF_NASCII:
15321 #ifdef HAS_ISASCII
15322                     op = (LOC) ? POSIXL : POSIXA;
15323 #else
15324                     op = POSIXA;
15325 #endif
15326                     goto join_posix;
15327
15328                 /* The following don't have any matches in the upper Latin1
15329                  * range, hence /d is equivalent to /u for them.  Making it /u
15330                  * saves some branches at runtime */
15331                 case ANYOF_DIGIT:
15332                 case ANYOF_NDIGIT:
15333                 case ANYOF_XDIGIT:
15334                 case ANYOF_NXDIGIT:
15335                     if (! DEPENDS_SEMANTICS) {
15336                         goto treat_as_default;
15337                     }
15338
15339                     op = POSIXU;
15340                     goto join_posix;
15341
15342                 /* The following change to CASED under /i */
15343                 case ANYOF_LOWER:
15344                 case ANYOF_NLOWER:
15345                 case ANYOF_UPPER:
15346                 case ANYOF_NUPPER:
15347                     if (FOLD) {
15348                         namedclass = ANYOF_CASED + (namedclass % 2);
15349                     }
15350                     /* FALLTHROUGH */
15351
15352                 /* The rest have more possibilities depending on the charset.
15353                  * We take advantage of the enum ordering of the charset
15354                  * modifiers to get the exact node type, */
15355                 default:
15356                   treat_as_default:
15357                     op = POSIXD + get_regex_charset(RExC_flags);
15358                     if (op > POSIXA) { /* /aa is same as /a */
15359                         op = POSIXA;
15360                     }
15361
15362                   join_posix:
15363                     /* The odd numbered ones are the complements of the
15364                      * next-lower even number one */
15365                     if (namedclass % 2 == 1) {
15366                         invert = ! invert;
15367                         namedclass--;
15368                     }
15369                     arg = namedclass_to_classnum(namedclass);
15370                     break;
15371             }
15372         }
15373         else if (value == prevvalue) {
15374
15375             /* Here, the class consists of just a single code point */
15376
15377             if (invert) {
15378                 if (! LOC && value == '\n') {
15379                     op = REG_ANY; /* Optimize [^\n] */
15380                     *flagp |= HASWIDTH|SIMPLE;
15381                     MARK_NAUGHTY(1);
15382                 }
15383             }
15384             else if (value < 256 || UTF) {
15385
15386                 /* Optimize a single value into an EXACTish node, but not if it
15387                  * would require converting the pattern to UTF-8. */
15388                 op = compute_EXACTish(pRExC_state);
15389             }
15390         } /* Otherwise is a range */
15391         else if (! LOC) {   /* locale could vary these */
15392             if (prevvalue == '0') {
15393                 if (value == '9') {
15394                     arg = _CC_DIGIT;
15395                     op = POSIXA;
15396                 }
15397             }
15398             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
15399                 /* We can optimize A-Z or a-z, but not if they could match
15400                  * something like the KELVIN SIGN under /i. */
15401                 if (prevvalue == 'A') {
15402                     if (value == 'Z'
15403 #ifdef EBCDIC
15404                         && ! non_portable_endpoint
15405 #endif
15406                     ) {
15407                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
15408                         op = POSIXA;
15409                     }
15410                 }
15411                 else if (prevvalue == 'a') {
15412                     if (value == 'z'
15413 #ifdef EBCDIC
15414                         && ! non_portable_endpoint
15415 #endif
15416                     ) {
15417                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
15418                         op = POSIXA;
15419                     }
15420                 }
15421             }
15422         }
15423
15424         /* Here, we have changed <op> away from its initial value iff we found
15425          * an optimization */
15426         if (op != END) {
15427
15428             /* Throw away this ANYOF regnode, and emit the calculated one,
15429              * which should correspond to the beginning, not current, state of
15430              * the parse */
15431             const char * cur_parse = RExC_parse;
15432             RExC_parse = (char *)orig_parse;
15433             if ( SIZE_ONLY) {
15434                 if (! LOC) {
15435
15436                     /* To get locale nodes to not use the full ANYOF size would
15437                      * require moving the code above that writes the portions
15438                      * of it that aren't in other nodes to after this point.
15439                      * e.g.  ANYOF_POSIXL_SET */
15440                     RExC_size = orig_size;
15441                 }
15442             }
15443             else {
15444                 RExC_emit = (regnode *)orig_emit;
15445                 if (PL_regkind[op] == POSIXD) {
15446                     if (op == POSIXL) {
15447                         RExC_contains_locale = 1;
15448                     }
15449                     if (invert) {
15450                         op += NPOSIXD - POSIXD;
15451                     }
15452                 }
15453             }
15454
15455             ret = reg_node(pRExC_state, op);
15456
15457             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
15458                 if (! SIZE_ONLY) {
15459                     FLAGS(ret) = arg;
15460                 }
15461                 *flagp |= HASWIDTH|SIMPLE;
15462             }
15463             else if (PL_regkind[op] == EXACT) {
15464                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
15465                                            TRUE /* downgradable to EXACT */
15466                                            );
15467             }
15468
15469             RExC_parse = (char *) cur_parse;
15470
15471             SvREFCNT_dec(posixes);
15472             SvREFCNT_dec(nposixes);
15473             SvREFCNT_dec(simple_posixes);
15474             SvREFCNT_dec(cp_list);
15475             SvREFCNT_dec(cp_foldable_list);
15476             return ret;
15477         }
15478     }
15479
15480     if (SIZE_ONLY)
15481         return ret;
15482     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
15483
15484     /* If folding, we calculate all characters that could fold to or from the
15485      * ones already on the list */
15486     if (cp_foldable_list) {
15487         if (FOLD) {
15488             UV start, end;      /* End points of code point ranges */
15489
15490             SV* fold_intersection = NULL;
15491             SV** use_list;
15492
15493             /* Our calculated list will be for Unicode rules.  For locale
15494              * matching, we have to keep a separate list that is consulted at
15495              * runtime only when the locale indicates Unicode rules.  For
15496              * non-locale, we just use to the general list */
15497             if (LOC) {
15498                 use_list = &only_utf8_locale_list;
15499             }
15500             else {
15501                 use_list = &cp_list;
15502             }
15503
15504             /* Only the characters in this class that participate in folds need
15505              * be checked.  Get the intersection of this class and all the
15506              * possible characters that are foldable.  This can quickly narrow
15507              * down a large class */
15508             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
15509                                   &fold_intersection);
15510
15511             /* The folds for all the Latin1 characters are hard-coded into this
15512              * program, but we have to go out to disk to get the others. */
15513             if (invlist_highest(cp_foldable_list) >= 256) {
15514
15515                 /* This is a hash that for a particular fold gives all
15516                  * characters that are involved in it */
15517                 if (! PL_utf8_foldclosures) {
15518                     _load_PL_utf8_foldclosures();
15519                 }
15520             }
15521
15522             /* Now look at the foldable characters in this class individually */
15523             invlist_iterinit(fold_intersection);
15524             while (invlist_iternext(fold_intersection, &start, &end)) {
15525                 UV j;
15526
15527                 /* Look at every character in the range */
15528                 for (j = start; j <= end; j++) {
15529                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
15530                     STRLEN foldlen;
15531                     SV** listp;
15532
15533                     if (j < 256) {
15534
15535                         if (IS_IN_SOME_FOLD_L1(j)) {
15536
15537                             /* ASCII is always matched; non-ASCII is matched
15538                              * only under Unicode rules (which could happen
15539                              * under /l if the locale is a UTF-8 one */
15540                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
15541                                 *use_list = add_cp_to_invlist(*use_list,
15542                                                             PL_fold_latin1[j]);
15543                             }
15544                             else {
15545                                 depends_list =
15546                                  add_cp_to_invlist(depends_list,
15547                                                    PL_fold_latin1[j]);
15548                             }
15549                         }
15550
15551                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
15552                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
15553                         {
15554                             add_above_Latin1_folds(pRExC_state,
15555                                                    (U8) j,
15556                                                    use_list);
15557                         }
15558                         continue;
15559                     }
15560
15561                     /* Here is an above Latin1 character.  We don't have the
15562                      * rules hard-coded for it.  First, get its fold.  This is
15563                      * the simple fold, as the multi-character folds have been
15564                      * handled earlier and separated out */
15565                     _to_uni_fold_flags(j, foldbuf, &foldlen,
15566                                                         (ASCII_FOLD_RESTRICTED)
15567                                                         ? FOLD_FLAGS_NOMIX_ASCII
15568                                                         : 0);
15569
15570                     /* Single character fold of above Latin1.  Add everything in
15571                     * its fold closure to the list that this node should match.
15572                     * The fold closures data structure is a hash with the keys
15573                     * being the UTF-8 of every character that is folded to, like
15574                     * 'k', and the values each an array of all code points that
15575                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
15576                     * Multi-character folds are not included */
15577                     if ((listp = hv_fetch(PL_utf8_foldclosures,
15578                                         (char *) foldbuf, foldlen, FALSE)))
15579                     {
15580                         AV* list = (AV*) *listp;
15581                         IV k;
15582                         for (k = 0; k <= av_tindex(list); k++) {
15583                             SV** c_p = av_fetch(list, k, FALSE);
15584                             UV c;
15585                             assert(c_p);
15586
15587                             c = SvUV(*c_p);
15588
15589                             /* /aa doesn't allow folds between ASCII and non- */
15590                             if ((ASCII_FOLD_RESTRICTED
15591                                 && (isASCII(c) != isASCII(j))))
15592                             {
15593                                 continue;
15594                             }
15595
15596                             /* Folds under /l which cross the 255/256 boundary
15597                              * are added to a separate list.  (These are valid
15598                              * only when the locale is UTF-8.) */
15599                             if (c < 256 && LOC) {
15600                                 *use_list = add_cp_to_invlist(*use_list, c);
15601                                 continue;
15602                             }
15603
15604                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
15605                             {
15606                                 cp_list = add_cp_to_invlist(cp_list, c);
15607                             }
15608                             else {
15609                                 /* Similarly folds involving non-ascii Latin1
15610                                 * characters under /d are added to their list */
15611                                 depends_list = add_cp_to_invlist(depends_list,
15612                                                                  c);
15613                             }
15614                         }
15615                     }
15616                 }
15617             }
15618             SvREFCNT_dec_NN(fold_intersection);
15619         }
15620
15621         /* Now that we have finished adding all the folds, there is no reason
15622          * to keep the foldable list separate */
15623         _invlist_union(cp_list, cp_foldable_list, &cp_list);
15624         SvREFCNT_dec_NN(cp_foldable_list);
15625     }
15626
15627     /* And combine the result (if any) with any inversion list from posix
15628      * classes.  The lists are kept separate up to now because we don't want to
15629      * fold the classes (folding of those is automatically handled by the swash
15630      * fetching code) */
15631     if (simple_posixes) {
15632         _invlist_union(cp_list, simple_posixes, &cp_list);
15633         SvREFCNT_dec_NN(simple_posixes);
15634     }
15635     if (posixes || nposixes) {
15636         if (posixes && AT_LEAST_ASCII_RESTRICTED) {
15637             /* Under /a and /aa, nothing above ASCII matches these */
15638             _invlist_intersection(posixes,
15639                                   PL_XPosix_ptrs[_CC_ASCII],
15640                                   &posixes);
15641         }
15642         if (nposixes) {
15643             if (DEPENDS_SEMANTICS) {
15644                 /* Under /d, everything in the upper half of the Latin1 range
15645                  * matches these complements */
15646                 ANYOF_FLAGS(ret) |= ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII;
15647             }
15648             else if (AT_LEAST_ASCII_RESTRICTED) {
15649                 /* Under /a and /aa, everything above ASCII matches these
15650                  * complements */
15651                 _invlist_union_complement_2nd(nposixes,
15652                                               PL_XPosix_ptrs[_CC_ASCII],
15653                                               &nposixes);
15654             }
15655             if (posixes) {
15656                 _invlist_union(posixes, nposixes, &posixes);
15657                 SvREFCNT_dec_NN(nposixes);
15658             }
15659             else {
15660                 posixes = nposixes;
15661             }
15662         }
15663         if (! DEPENDS_SEMANTICS) {
15664             if (cp_list) {
15665                 _invlist_union(cp_list, posixes, &cp_list);
15666                 SvREFCNT_dec_NN(posixes);
15667             }
15668             else {
15669                 cp_list = posixes;
15670             }
15671         }
15672         else {
15673             /* Under /d, we put into a separate list the Latin1 things that
15674              * match only when the target string is utf8 */
15675             SV* nonascii_but_latin1_properties = NULL;
15676             _invlist_intersection(posixes, PL_UpperLatin1,
15677                                   &nonascii_but_latin1_properties);
15678             _invlist_subtract(posixes, nonascii_but_latin1_properties,
15679                               &posixes);
15680             if (cp_list) {
15681                 _invlist_union(cp_list, posixes, &cp_list);
15682                 SvREFCNT_dec_NN(posixes);
15683             }
15684             else {
15685                 cp_list = posixes;
15686             }
15687
15688             if (depends_list) {
15689                 _invlist_union(depends_list, nonascii_but_latin1_properties,
15690                                &depends_list);
15691                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
15692             }
15693             else {
15694                 depends_list = nonascii_but_latin1_properties;
15695             }
15696         }
15697     }
15698
15699     /* And combine the result (if any) with any inversion list from properties.
15700      * The lists are kept separate up to now so that we can distinguish the two
15701      * in regards to matching above-Unicode.  A run-time warning is generated
15702      * if a Unicode property is matched against a non-Unicode code point. But,
15703      * we allow user-defined properties to match anything, without any warning,
15704      * and we also suppress the warning if there is a portion of the character
15705      * class that isn't a Unicode property, and which matches above Unicode, \W
15706      * or [\x{110000}] for example.
15707      * (Note that in this case, unlike the Posix one above, there is no
15708      * <depends_list>, because having a Unicode property forces Unicode
15709      * semantics */
15710     if (properties) {
15711         if (cp_list) {
15712
15713             /* If it matters to the final outcome, see if a non-property
15714              * component of the class matches above Unicode.  If so, the
15715              * warning gets suppressed.  This is true even if just a single
15716              * such code point is specified, as though not strictly correct if
15717              * another such code point is matched against, the fact that they
15718              * are using above-Unicode code points indicates they should know
15719              * the issues involved */
15720             if (warn_super) {
15721                 warn_super = ! (invert
15722                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
15723             }
15724
15725             _invlist_union(properties, cp_list, &cp_list);
15726             SvREFCNT_dec_NN(properties);
15727         }
15728         else {
15729             cp_list = properties;
15730         }
15731
15732         if (warn_super) {
15733             ANYOF_FLAGS(ret) |= ANYOF_WARN_SUPER;
15734         }
15735     }
15736
15737     /* Here, we have calculated what code points should be in the character
15738      * class.
15739      *
15740      * Now we can see about various optimizations.  Fold calculation (which we
15741      * did above) needs to take place before inversion.  Otherwise /[^k]/i
15742      * would invert to include K, which under /i would match k, which it
15743      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
15744      * folded until runtime */
15745
15746     /* If we didn't do folding, it's because some information isn't available
15747      * until runtime; set the run-time fold flag for these.  (We don't have to
15748      * worry about properties folding, as that is taken care of by the swash
15749      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
15750      * locales, or the class matches at least one 0-255 range code point */
15751     if (LOC && FOLD) {
15752         if (only_utf8_locale_list) {
15753             ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
15754         }
15755         else if (cp_list) { /* Look to see if there a 0-255 code point is in
15756                                the list */
15757             UV start, end;
15758             invlist_iterinit(cp_list);
15759             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
15760                 ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
15761             }
15762             invlist_iterfinish(cp_list);
15763         }
15764     }
15765
15766     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
15767      * at compile time.  Besides not inverting folded locale now, we can't
15768      * invert if there are things such as \w, which aren't known until runtime
15769      * */
15770     if (cp_list
15771         && invert
15772         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
15773         && ! depends_list
15774         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
15775     {
15776         _invlist_invert(cp_list);
15777
15778         /* Any swash can't be used as-is, because we've inverted things */
15779         if (swash) {
15780             SvREFCNT_dec_NN(swash);
15781             swash = NULL;
15782         }
15783
15784         /* Clear the invert flag since have just done it here */
15785         invert = FALSE;
15786     }
15787
15788     if (ret_invlist) {
15789         assert(cp_list);
15790
15791         *ret_invlist = cp_list;
15792         SvREFCNT_dec(swash);
15793
15794         /* Discard the generated node */
15795         if (SIZE_ONLY) {
15796             RExC_size = orig_size;
15797         }
15798         else {
15799             RExC_emit = orig_emit;
15800         }
15801         return orig_emit;
15802     }
15803
15804     /* Some character classes are equivalent to other nodes.  Such nodes take
15805      * up less room and generally fewer operations to execute than ANYOF nodes.
15806      * Above, we checked for and optimized into some such equivalents for
15807      * certain common classes that are easy to test.  Getting to this point in
15808      * the code means that the class didn't get optimized there.  Since this
15809      * code is only executed in Pass 2, it is too late to save space--it has
15810      * been allocated in Pass 1, and currently isn't given back.  But turning
15811      * things into an EXACTish node can allow the optimizer to join it to any
15812      * adjacent such nodes.  And if the class is equivalent to things like /./,
15813      * expensive run-time swashes can be avoided.  Now that we have more
15814      * complete information, we can find things necessarily missed by the
15815      * earlier code.  I (khw) am not sure how much to look for here.  It would
15816      * be easy, but perhaps too slow, to check any candidates against all the
15817      * node types they could possibly match using _invlistEQ(). */
15818
15819     if (cp_list
15820         && ! invert
15821         && ! depends_list
15822         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
15823         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
15824
15825            /* We don't optimize if we are supposed to make sure all non-Unicode
15826             * code points raise a warning, as only ANYOF nodes have this check.
15827             * */
15828         && ! ((ANYOF_FLAGS(ret) & ANYOF_WARN_SUPER) && ALWAYS_WARN_SUPER))
15829     {
15830         UV start, end;
15831         U8 op = END;  /* The optimzation node-type */
15832         const char * cur_parse= RExC_parse;
15833
15834         invlist_iterinit(cp_list);
15835         if (! invlist_iternext(cp_list, &start, &end)) {
15836
15837             /* Here, the list is empty.  This happens, for example, when a
15838              * Unicode property is the only thing in the character class, and
15839              * it doesn't match anything.  (perluniprops.pod notes such
15840              * properties) */
15841             op = OPFAIL;
15842             *flagp |= HASWIDTH|SIMPLE;
15843         }
15844         else if (start == end) {    /* The range is a single code point */
15845             if (! invlist_iternext(cp_list, &start, &end)
15846
15847                     /* Don't do this optimization if it would require changing
15848                      * the pattern to UTF-8 */
15849                 && (start < 256 || UTF))
15850             {
15851                 /* Here, the list contains a single code point.  Can optimize
15852                  * into an EXACTish node */
15853
15854                 value = start;
15855
15856                 if (! FOLD) {
15857                     op = (LOC)
15858                          ? EXACTL
15859                          : EXACT;
15860                 }
15861                 else if (LOC) {
15862
15863                     /* A locale node under folding with one code point can be
15864                      * an EXACTFL, as its fold won't be calculated until
15865                      * runtime */
15866                     op = EXACTFL;
15867                 }
15868                 else {
15869
15870                     /* Here, we are generally folding, but there is only one
15871                      * code point to match.  If we have to, we use an EXACT
15872                      * node, but it would be better for joining with adjacent
15873                      * nodes in the optimization pass if we used the same
15874                      * EXACTFish node that any such are likely to be.  We can
15875                      * do this iff the code point doesn't participate in any
15876                      * folds.  For example, an EXACTF of a colon is the same as
15877                      * an EXACT one, since nothing folds to or from a colon. */
15878                     if (value < 256) {
15879                         if (IS_IN_SOME_FOLD_L1(value)) {
15880                             op = EXACT;
15881                         }
15882                     }
15883                     else {
15884                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
15885                             op = EXACT;
15886                         }
15887                     }
15888
15889                     /* If we haven't found the node type, above, it means we
15890                      * can use the prevailing one */
15891                     if (op == END) {
15892                         op = compute_EXACTish(pRExC_state);
15893                     }
15894                 }
15895             }
15896         }
15897         else if (start == 0) {
15898             if (end == UV_MAX) {
15899                 op = SANY;
15900                 *flagp |= HASWIDTH|SIMPLE;
15901                 MARK_NAUGHTY(1);
15902             }
15903             else if (end == '\n' - 1
15904                     && invlist_iternext(cp_list, &start, &end)
15905                     && start == '\n' + 1 && end == UV_MAX)
15906             {
15907                 op = REG_ANY;
15908                 *flagp |= HASWIDTH|SIMPLE;
15909                 MARK_NAUGHTY(1);
15910             }
15911         }
15912         invlist_iterfinish(cp_list);
15913
15914         if (op != END) {
15915             RExC_parse = (char *)orig_parse;
15916             RExC_emit = (regnode *)orig_emit;
15917
15918             ret = reg_node(pRExC_state, op);
15919
15920             RExC_parse = (char *)cur_parse;
15921
15922             if (PL_regkind[op] == EXACT) {
15923                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
15924                                            TRUE /* downgradable to EXACT */
15925                                           );
15926             }
15927
15928             SvREFCNT_dec_NN(cp_list);
15929             return ret;
15930         }
15931     }
15932
15933     /* Here, <cp_list> contains all the code points we can determine at
15934      * compile time that match under all conditions.  Go through it, and
15935      * for things that belong in the bitmap, put them there, and delete from
15936      * <cp_list>.  While we are at it, see if everything above 255 is in the
15937      * list, and if so, set a flag to speed up execution */
15938
15939     populate_ANYOF_from_invlist(ret, &cp_list);
15940
15941     if (invert) {
15942         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
15943     }
15944
15945     /* Here, the bitmap has been populated with all the Latin1 code points that
15946      * always match.  Can now add to the overall list those that match only
15947      * when the target string is UTF-8 (<depends_list>). */
15948     if (depends_list) {
15949         if (cp_list) {
15950             _invlist_union(cp_list, depends_list, &cp_list);
15951             SvREFCNT_dec_NN(depends_list);
15952         }
15953         else {
15954             cp_list = depends_list;
15955         }
15956         ANYOF_FLAGS(ret) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES;
15957     }
15958
15959     /* If there is a swash and more than one element, we can't use the swash in
15960      * the optimization below. */
15961     if (swash && element_count > 1) {
15962         SvREFCNT_dec_NN(swash);
15963         swash = NULL;
15964     }
15965
15966     /* Note that the optimization of using 'swash' if it is the only thing in
15967      * the class doesn't have us change swash at all, so it can include things
15968      * that are also in the bitmap; otherwise we have purposely deleted that
15969      * duplicate information */
15970     set_ANYOF_arg(pRExC_state, ret, cp_list,
15971                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
15972                    ? listsv : NULL,
15973                   only_utf8_locale_list,
15974                   swash, has_user_defined_property);
15975
15976     *flagp |= HASWIDTH|SIMPLE;
15977
15978     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
15979         RExC_contains_locale = 1;
15980     }
15981
15982     return ret;
15983 }
15984
15985 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
15986
15987 STATIC void
15988 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
15989                 regnode* const node,
15990                 SV* const cp_list,
15991                 SV* const runtime_defns,
15992                 SV* const only_utf8_locale_list,
15993                 SV* const swash,
15994                 const bool has_user_defined_property)
15995 {
15996     /* Sets the arg field of an ANYOF-type node 'node', using information about
15997      * the node passed-in.  If there is nothing outside the node's bitmap, the
15998      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
15999      * the count returned by add_data(), having allocated and stored an array,
16000      * av, that that count references, as follows:
16001      *  av[0] stores the character class description in its textual form.
16002      *        This is used later (regexec.c:Perl_regclass_swash()) to
16003      *        initialize the appropriate swash, and is also useful for dumping
16004      *        the regnode.  This is set to &PL_sv_undef if the textual
16005      *        description is not needed at run-time (as happens if the other
16006      *        elements completely define the class)
16007      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
16008      *        computed from av[0].  But if no further computation need be done,
16009      *        the swash is stored here now (and av[0] is &PL_sv_undef).
16010      *  av[2] stores the inversion list of code points that match only if the
16011      *        current locale is UTF-8
16012      *  av[3] stores the cp_list inversion list for use in addition or instead
16013      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
16014      *        (Otherwise everything needed is already in av[0] and av[1])
16015      *  av[4] is set if any component of the class is from a user-defined
16016      *        property; used only if av[3] exists */
16017
16018     UV n;
16019
16020     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
16021
16022     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
16023         assert(! (ANYOF_FLAGS(node)
16024                   & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
16025                      |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES)));
16026         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
16027     }
16028     else {
16029         AV * const av = newAV();
16030         SV *rv;
16031
16032         assert(ANYOF_FLAGS(node)
16033                & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
16034                   |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD));
16035
16036         av_store(av, 0, (runtime_defns)
16037                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
16038         if (swash) {
16039             assert(cp_list);
16040             av_store(av, 1, swash);
16041             SvREFCNT_dec_NN(cp_list);
16042         }
16043         else {
16044             av_store(av, 1, &PL_sv_undef);
16045             if (cp_list) {
16046                 av_store(av, 3, cp_list);
16047                 av_store(av, 4, newSVuv(has_user_defined_property));
16048             }
16049         }
16050
16051         if (only_utf8_locale_list) {
16052             av_store(av, 2, only_utf8_locale_list);
16053         }
16054         else {
16055             av_store(av, 2, &PL_sv_undef);
16056         }
16057
16058         rv = newRV_noinc(MUTABLE_SV(av));
16059         n = add_data(pRExC_state, STR_WITH_LEN("s"));
16060         RExC_rxi->data->data[n] = (void*)rv;
16061         ARG_SET(node, n);
16062     }
16063 }
16064
16065 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
16066 SV *
16067 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
16068                                         const regnode* node,
16069                                         bool doinit,
16070                                         SV** listsvp,
16071                                         SV** only_utf8_locale_ptr,
16072                                         SV*  exclude_list)
16073
16074 {
16075     /* For internal core use only.
16076      * Returns the swash for the input 'node' in the regex 'prog'.
16077      * If <doinit> is 'true', will attempt to create the swash if not already
16078      *    done.
16079      * If <listsvp> is non-null, will return the printable contents of the
16080      *    swash.  This can be used to get debugging information even before the
16081      *    swash exists, by calling this function with 'doinit' set to false, in
16082      *    which case the components that will be used to eventually create the
16083      *    swash are returned  (in a printable form).
16084      * If <exclude_list> is not NULL, it is an inversion list of things to
16085      *    exclude from what's returned in <listsvp>.
16086      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
16087      * that, in spite of this function's name, the swash it returns may include
16088      * the bitmap data as well */
16089
16090     SV *sw  = NULL;
16091     SV *si  = NULL;         /* Input swash initialization string */
16092     SV*  invlist = NULL;
16093
16094     RXi_GET_DECL(prog,progi);
16095     const struct reg_data * const data = prog ? progi->data : NULL;
16096
16097     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
16098
16099     assert(ANYOF_FLAGS(node)
16100         & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
16101            |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD));
16102
16103     if (data && data->count) {
16104         const U32 n = ARG(node);
16105
16106         if (data->what[n] == 's') {
16107             SV * const rv = MUTABLE_SV(data->data[n]);
16108             AV * const av = MUTABLE_AV(SvRV(rv));
16109             SV **const ary = AvARRAY(av);
16110             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
16111
16112             si = *ary;  /* ary[0] = the string to initialize the swash with */
16113
16114             /* Elements 3 and 4 are either both present or both absent. [3] is
16115              * any inversion list generated at compile time; [4] indicates if
16116              * that inversion list has any user-defined properties in it. */
16117             if (av_tindex(av) >= 2) {
16118                 if (only_utf8_locale_ptr
16119                     && ary[2]
16120                     && ary[2] != &PL_sv_undef)
16121                 {
16122                     *only_utf8_locale_ptr = ary[2];
16123                 }
16124                 else {
16125                     assert(only_utf8_locale_ptr);
16126                     *only_utf8_locale_ptr = NULL;
16127                 }
16128
16129                 if (av_tindex(av) >= 3) {
16130                     invlist = ary[3];
16131                     if (SvUV(ary[4])) {
16132                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
16133                     }
16134                 }
16135                 else {
16136                     invlist = NULL;
16137                 }
16138             }
16139
16140             /* Element [1] is reserved for the set-up swash.  If already there,
16141              * return it; if not, create it and store it there */
16142             if (ary[1] && SvROK(ary[1])) {
16143                 sw = ary[1];
16144             }
16145             else if (doinit && ((si && si != &PL_sv_undef)
16146                                  || (invlist && invlist != &PL_sv_undef))) {
16147                 assert(si);
16148                 sw = _core_swash_init("utf8", /* the utf8 package */
16149                                       "", /* nameless */
16150                                       si,
16151                                       1, /* binary */
16152                                       0, /* not from tr/// */
16153                                       invlist,
16154                                       &swash_init_flags);
16155                 (void)av_store(av, 1, sw);
16156             }
16157         }
16158     }
16159
16160     /* If requested, return a printable version of what this swash matches */
16161     if (listsvp) {
16162         SV* matches_string = newSVpvs("");
16163
16164         /* The swash should be used, if possible, to get the data, as it
16165          * contains the resolved data.  But this function can be called at
16166          * compile-time, before everything gets resolved, in which case we
16167          * return the currently best available information, which is the string
16168          * that will eventually be used to do that resolving, 'si' */
16169         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
16170             && (si && si != &PL_sv_undef))
16171         {
16172             sv_catsv(matches_string, si);
16173         }
16174
16175         /* Add the inversion list to whatever we have.  This may have come from
16176          * the swash, or from an input parameter */
16177         if (invlist) {
16178             if (exclude_list) {
16179                 SV* clone = invlist_clone(invlist);
16180                 _invlist_subtract(clone, exclude_list, &clone);
16181                 sv_catsv(matches_string, _invlist_contents(clone));
16182                 SvREFCNT_dec_NN(clone);
16183             }
16184             else {
16185                 sv_catsv(matches_string, _invlist_contents(invlist));
16186             }
16187         }
16188         *listsvp = matches_string;
16189     }
16190
16191     return sw;
16192 }
16193 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
16194
16195 /* reg_skipcomment()
16196
16197    Absorbs an /x style # comment from the input stream,
16198    returning a pointer to the first character beyond the comment, or if the
16199    comment terminates the pattern without anything following it, this returns
16200    one past the final character of the pattern (in other words, RExC_end) and
16201    sets the REG_RUN_ON_COMMENT_SEEN flag.
16202
16203    Note it's the callers responsibility to ensure that we are
16204    actually in /x mode
16205
16206 */
16207
16208 PERL_STATIC_INLINE char*
16209 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
16210 {
16211     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
16212
16213     assert(*p == '#');
16214
16215     while (p < RExC_end) {
16216         if (*(++p) == '\n') {
16217             return p+1;
16218         }
16219     }
16220
16221     /* we ran off the end of the pattern without ending the comment, so we have
16222      * to add an \n when wrapping */
16223     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
16224     return p;
16225 }
16226
16227 /* nextchar()
16228
16229    Advances the parse position, and optionally absorbs
16230    "whitespace" from the inputstream.
16231
16232    Without /x "whitespace" means (?#...) style comments only,
16233    with /x this means (?#...) and # comments and whitespace proper.
16234
16235    Returns the RExC_parse point from BEFORE the scan occurs.
16236
16237    This is the /x friendly way of saying RExC_parse++.
16238 */
16239
16240 STATIC char*
16241 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
16242 {
16243     char* const retval = RExC_parse++;
16244
16245     PERL_ARGS_ASSERT_NEXTCHAR;
16246
16247     for (;;) {
16248         if (RExC_end - RExC_parse >= 3
16249             && *RExC_parse == '('
16250             && RExC_parse[1] == '?'
16251             && RExC_parse[2] == '#')
16252         {
16253             while (*RExC_parse != ')') {
16254                 if (RExC_parse == RExC_end)
16255                     FAIL("Sequence (?#... not terminated");
16256                 RExC_parse++;
16257             }
16258             RExC_parse++;
16259             continue;
16260         }
16261         if (RExC_flags & RXf_PMf_EXTENDED) {
16262             char * p = regpatws(pRExC_state, RExC_parse,
16263                                           TRUE); /* means recognize comments */
16264             if (p != RExC_parse) {
16265                 RExC_parse = p;
16266                 continue;
16267             }
16268         }
16269         return retval;
16270     }
16271 }
16272
16273 STATIC regnode *
16274 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
16275 {
16276     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
16277      * space.  In pass1, it aligns and increments RExC_size; in pass2,
16278      * RExC_emit */
16279
16280     regnode * const ret = RExC_emit;
16281     GET_RE_DEBUG_FLAGS_DECL;
16282
16283     PERL_ARGS_ASSERT_REGNODE_GUTS;
16284
16285     assert(extra_size >= regarglen[op]);
16286
16287     if (SIZE_ONLY) {
16288         SIZE_ALIGN(RExC_size);
16289         RExC_size += 1 + extra_size;
16290         return(ret);
16291     }
16292     if (RExC_emit >= RExC_emit_bound)
16293         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
16294                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
16295
16296     NODE_ALIGN_FILL(ret);
16297 #ifndef RE_TRACK_PATTERN_OFFSETS
16298     PERL_UNUSED_ARG(name);
16299 #else
16300     if (RExC_offsets) {         /* MJD */
16301         MJD_OFFSET_DEBUG(
16302               ("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
16303               name, __LINE__,
16304               PL_reg_name[op],
16305               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
16306                 ? "Overwriting end of array!\n" : "OK",
16307               (UV)(RExC_emit - RExC_emit_start),
16308               (UV)(RExC_parse - RExC_start),
16309               (UV)RExC_offsets[0]));
16310         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
16311     }
16312 #endif
16313     return(ret);
16314 }
16315
16316 /*
16317 - reg_node - emit a node
16318 */
16319 STATIC regnode *                        /* Location. */
16320 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
16321 {
16322     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
16323
16324     PERL_ARGS_ASSERT_REG_NODE;
16325
16326     assert(regarglen[op] == 0);
16327
16328     if (PASS2) {
16329         regnode *ptr = ret;
16330         FILL_ADVANCE_NODE(ptr, op);
16331         RExC_emit = ptr;
16332     }
16333     return(ret);
16334 }
16335
16336 /*
16337 - reganode - emit a node with an argument
16338 */
16339 STATIC regnode *                        /* Location. */
16340 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
16341 {
16342     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
16343
16344     PERL_ARGS_ASSERT_REGANODE;
16345
16346     assert(regarglen[op] == 1);
16347
16348     if (PASS2) {
16349         regnode *ptr = ret;
16350         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
16351         RExC_emit = ptr;
16352     }
16353     return(ret);
16354 }
16355
16356 STATIC regnode *
16357 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
16358 {
16359     /* emit a node with U32 and I32 arguments */
16360
16361     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
16362
16363     PERL_ARGS_ASSERT_REG2LANODE;
16364
16365     assert(regarglen[op] == 2);
16366
16367     if (PASS2) {
16368         regnode *ptr = ret;
16369         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
16370         RExC_emit = ptr;
16371     }
16372     return(ret);
16373 }
16374
16375 /*
16376 - reginsert - insert an operator in front of already-emitted operand
16377 *
16378 * Means relocating the operand.
16379 */
16380 STATIC void
16381 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
16382 {
16383     regnode *src;
16384     regnode *dst;
16385     regnode *place;
16386     const int offset = regarglen[(U8)op];
16387     const int size = NODE_STEP_REGNODE + offset;
16388     GET_RE_DEBUG_FLAGS_DECL;
16389
16390     PERL_ARGS_ASSERT_REGINSERT;
16391     PERL_UNUSED_CONTEXT;
16392     PERL_UNUSED_ARG(depth);
16393 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
16394     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
16395     if (SIZE_ONLY) {
16396         RExC_size += size;
16397         return;
16398     }
16399
16400     src = RExC_emit;
16401     RExC_emit += size;
16402     dst = RExC_emit;
16403     if (RExC_open_parens) {
16404         int paren;
16405         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
16406         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
16407             if ( RExC_open_parens[paren] >= opnd ) {
16408                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
16409                 RExC_open_parens[paren] += size;
16410             } else {
16411                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
16412             }
16413             if ( RExC_close_parens[paren] >= opnd ) {
16414                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
16415                 RExC_close_parens[paren] += size;
16416             } else {
16417                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
16418             }
16419         }
16420     }
16421
16422     while (src > opnd) {
16423         StructCopy(--src, --dst, regnode);
16424 #ifdef RE_TRACK_PATTERN_OFFSETS
16425         if (RExC_offsets) {     /* MJD 20010112 */
16426             MJD_OFFSET_DEBUG(
16427                  ("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
16428                   "reg_insert",
16429                   __LINE__,
16430                   PL_reg_name[op],
16431                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
16432                     ? "Overwriting end of array!\n" : "OK",
16433                   (UV)(src - RExC_emit_start),
16434                   (UV)(dst - RExC_emit_start),
16435                   (UV)RExC_offsets[0]));
16436             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
16437             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
16438         }
16439 #endif
16440     }
16441
16442
16443     place = opnd;               /* Op node, where operand used to be. */
16444 #ifdef RE_TRACK_PATTERN_OFFSETS
16445     if (RExC_offsets) {         /* MJD */
16446         MJD_OFFSET_DEBUG(
16447               ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
16448               "reginsert",
16449               __LINE__,
16450               PL_reg_name[op],
16451               (UV)(place - RExC_emit_start) > RExC_offsets[0]
16452               ? "Overwriting end of array!\n" : "OK",
16453               (UV)(place - RExC_emit_start),
16454               (UV)(RExC_parse - RExC_start),
16455               (UV)RExC_offsets[0]));
16456         Set_Node_Offset(place, RExC_parse);
16457         Set_Node_Length(place, 1);
16458     }
16459 #endif
16460     src = NEXTOPER(place);
16461     FILL_ADVANCE_NODE(place, op);
16462     Zero(src, offset, regnode);
16463 }
16464
16465 /*
16466 - regtail - set the next-pointer at the end of a node chain of p to val.
16467 - SEE ALSO: regtail_study
16468 */
16469 /* TODO: All three parms should be const */
16470 STATIC void
16471 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p,
16472                 const regnode *val,U32 depth)
16473 {
16474     regnode *scan;
16475     GET_RE_DEBUG_FLAGS_DECL;
16476
16477     PERL_ARGS_ASSERT_REGTAIL;
16478 #ifndef DEBUGGING
16479     PERL_UNUSED_ARG(depth);
16480 #endif
16481
16482     if (SIZE_ONLY)
16483         return;
16484
16485     /* Find last node. */
16486     scan = p;
16487     for (;;) {
16488         regnode * const temp = regnext(scan);
16489         DEBUG_PARSE_r({
16490             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
16491             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
16492             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
16493                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
16494                     (temp == NULL ? "->" : ""),
16495                     (temp == NULL ? PL_reg_name[OP(val)] : "")
16496             );
16497         });
16498         if (temp == NULL)
16499             break;
16500         scan = temp;
16501     }
16502
16503     if (reg_off_by_arg[OP(scan)]) {
16504         ARG_SET(scan, val - scan);
16505     }
16506     else {
16507         NEXT_OFF(scan) = val - scan;
16508     }
16509 }
16510
16511 #ifdef DEBUGGING
16512 /*
16513 - regtail_study - set the next-pointer at the end of a node chain of p to val.
16514 - Look for optimizable sequences at the same time.
16515 - currently only looks for EXACT chains.
16516
16517 This is experimental code. The idea is to use this routine to perform
16518 in place optimizations on branches and groups as they are constructed,
16519 with the long term intention of removing optimization from study_chunk so
16520 that it is purely analytical.
16521
16522 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
16523 to control which is which.
16524
16525 */
16526 /* TODO: All four parms should be const */
16527
16528 STATIC U8
16529 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
16530                       const regnode *val,U32 depth)
16531 {
16532     regnode *scan;
16533     U8 exact = PSEUDO;
16534 #ifdef EXPERIMENTAL_INPLACESCAN
16535     I32 min = 0;
16536 #endif
16537     GET_RE_DEBUG_FLAGS_DECL;
16538
16539     PERL_ARGS_ASSERT_REGTAIL_STUDY;
16540
16541
16542     if (SIZE_ONLY)
16543         return exact;
16544
16545     /* Find last node. */
16546
16547     scan = p;
16548     for (;;) {
16549         regnode * const temp = regnext(scan);
16550 #ifdef EXPERIMENTAL_INPLACESCAN
16551         if (PL_regkind[OP(scan)] == EXACT) {
16552             bool unfolded_multi_char;   /* Unexamined in this routine */
16553             if (join_exact(pRExC_state, scan, &min,
16554                            &unfolded_multi_char, 1, val, depth+1))
16555                 return EXACT;
16556         }
16557 #endif
16558         if ( exact ) {
16559             switch (OP(scan)) {
16560                 case EXACT:
16561                 case EXACTL:
16562                 case EXACTF:
16563                 case EXACTFA_NO_TRIE:
16564                 case EXACTFA:
16565                 case EXACTFU:
16566                 case EXACTFLU8:
16567                 case EXACTFU_SS:
16568                 case EXACTFL:
16569                         if( exact == PSEUDO )
16570                             exact= OP(scan);
16571                         else if ( exact != OP(scan) )
16572                             exact= 0;
16573                 case NOTHING:
16574                     break;
16575                 default:
16576                     exact= 0;
16577             }
16578         }
16579         DEBUG_PARSE_r({
16580             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
16581             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
16582             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
16583                 SvPV_nolen_const(RExC_mysv),
16584                 REG_NODE_NUM(scan),
16585                 PL_reg_name[exact]);
16586         });
16587         if (temp == NULL)
16588             break;
16589         scan = temp;
16590     }
16591     DEBUG_PARSE_r({
16592         DEBUG_PARSE_MSG("");
16593         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
16594         PerlIO_printf(Perl_debug_log,
16595                       "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
16596                       SvPV_nolen_const(RExC_mysv),
16597                       (IV)REG_NODE_NUM(val),
16598                       (IV)(val - scan)
16599         );
16600     });
16601     if (reg_off_by_arg[OP(scan)]) {
16602         ARG_SET(scan, val - scan);
16603     }
16604     else {
16605         NEXT_OFF(scan) = val - scan;
16606     }
16607
16608     return exact;
16609 }
16610 #endif
16611
16612 /*
16613  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
16614  */
16615 #ifdef DEBUGGING
16616
16617 static void
16618 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
16619 {
16620     int bit;
16621     int set=0;
16622
16623     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
16624
16625     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
16626         if (flags & (1<<bit)) {
16627             if (!set++ && lead)
16628                 PerlIO_printf(Perl_debug_log, "%s",lead);
16629             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_intflags_name[bit]);
16630         }
16631     }
16632     if (lead)  {
16633         if (set)
16634             PerlIO_printf(Perl_debug_log, "\n");
16635         else
16636             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
16637     }
16638 }
16639
16640 static void
16641 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
16642 {
16643     int bit;
16644     int set=0;
16645     regex_charset cs;
16646
16647     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
16648
16649     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
16650         if (flags & (1<<bit)) {
16651             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
16652                 continue;
16653             }
16654             if (!set++ && lead)
16655                 PerlIO_printf(Perl_debug_log, "%s",lead);
16656             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
16657         }
16658     }
16659     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
16660             if (!set++ && lead) {
16661                 PerlIO_printf(Perl_debug_log, "%s",lead);
16662             }
16663             switch (cs) {
16664                 case REGEX_UNICODE_CHARSET:
16665                     PerlIO_printf(Perl_debug_log, "UNICODE");
16666                     break;
16667                 case REGEX_LOCALE_CHARSET:
16668                     PerlIO_printf(Perl_debug_log, "LOCALE");
16669                     break;
16670                 case REGEX_ASCII_RESTRICTED_CHARSET:
16671                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
16672                     break;
16673                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
16674                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
16675                     break;
16676                 default:
16677                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
16678                     break;
16679             }
16680     }
16681     if (lead)  {
16682         if (set)
16683             PerlIO_printf(Perl_debug_log, "\n");
16684         else
16685             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
16686     }
16687 }
16688 #endif
16689
16690 void
16691 Perl_regdump(pTHX_ const regexp *r)
16692 {
16693 #ifdef DEBUGGING
16694     SV * const sv = sv_newmortal();
16695     SV *dsv= sv_newmortal();
16696     RXi_GET_DECL(r,ri);
16697     GET_RE_DEBUG_FLAGS_DECL;
16698
16699     PERL_ARGS_ASSERT_REGDUMP;
16700
16701     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
16702
16703     /* Header fields of interest. */
16704     if (r->anchored_substr) {
16705         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
16706             RE_SV_DUMPLEN(r->anchored_substr), 30);
16707         PerlIO_printf(Perl_debug_log,
16708                       "anchored %s%s at %"IVdf" ",
16709                       s, RE_SV_TAIL(r->anchored_substr),
16710                       (IV)r->anchored_offset);
16711     } else if (r->anchored_utf8) {
16712         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
16713             RE_SV_DUMPLEN(r->anchored_utf8), 30);
16714         PerlIO_printf(Perl_debug_log,
16715                       "anchored utf8 %s%s at %"IVdf" ",
16716                       s, RE_SV_TAIL(r->anchored_utf8),
16717                       (IV)r->anchored_offset);
16718     }
16719     if (r->float_substr) {
16720         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
16721             RE_SV_DUMPLEN(r->float_substr), 30);
16722         PerlIO_printf(Perl_debug_log,
16723                       "floating %s%s at %"IVdf"..%"UVuf" ",
16724                       s, RE_SV_TAIL(r->float_substr),
16725                       (IV)r->float_min_offset, (UV)r->float_max_offset);
16726     } else if (r->float_utf8) {
16727         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
16728             RE_SV_DUMPLEN(r->float_utf8), 30);
16729         PerlIO_printf(Perl_debug_log,
16730                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
16731                       s, RE_SV_TAIL(r->float_utf8),
16732                       (IV)r->float_min_offset, (UV)r->float_max_offset);
16733     }
16734     if (r->check_substr || r->check_utf8)
16735         PerlIO_printf(Perl_debug_log,
16736                       (const char *)
16737                       (r->check_substr == r->float_substr
16738                        && r->check_utf8 == r->float_utf8
16739                        ? "(checking floating" : "(checking anchored"));
16740     if (r->intflags & PREGf_NOSCAN)
16741         PerlIO_printf(Perl_debug_log, " noscan");
16742     if (r->extflags & RXf_CHECK_ALL)
16743         PerlIO_printf(Perl_debug_log, " isall");
16744     if (r->check_substr || r->check_utf8)
16745         PerlIO_printf(Perl_debug_log, ") ");
16746
16747     if (ri->regstclass) {
16748         regprop(r, sv, ri->regstclass, NULL, NULL);
16749         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
16750     }
16751     if (r->intflags & PREGf_ANCH) {
16752         PerlIO_printf(Perl_debug_log, "anchored");
16753         if (r->intflags & PREGf_ANCH_MBOL)
16754             PerlIO_printf(Perl_debug_log, "(MBOL)");
16755         if (r->intflags & PREGf_ANCH_SBOL)
16756             PerlIO_printf(Perl_debug_log, "(SBOL)");
16757         if (r->intflags & PREGf_ANCH_GPOS)
16758             PerlIO_printf(Perl_debug_log, "(GPOS)");
16759         PerlIO_putc(Perl_debug_log, ' ');
16760     }
16761     if (r->intflags & PREGf_GPOS_SEEN)
16762         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
16763     if (r->intflags & PREGf_SKIP)
16764         PerlIO_printf(Perl_debug_log, "plus ");
16765     if (r->intflags & PREGf_IMPLICIT)
16766         PerlIO_printf(Perl_debug_log, "implicit ");
16767     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
16768     if (r->extflags & RXf_EVAL_SEEN)
16769         PerlIO_printf(Perl_debug_log, "with eval ");
16770     PerlIO_printf(Perl_debug_log, "\n");
16771     DEBUG_FLAGS_r({
16772         regdump_extflags("r->extflags: ",r->extflags);
16773         regdump_intflags("r->intflags: ",r->intflags);
16774     });
16775 #else
16776     PERL_ARGS_ASSERT_REGDUMP;
16777     PERL_UNUSED_CONTEXT;
16778     PERL_UNUSED_ARG(r);
16779 #endif  /* DEBUGGING */
16780 }
16781
16782 /*
16783 - regprop - printable representation of opcode, with run time support
16784 */
16785
16786 void
16787 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
16788 {
16789 #ifdef DEBUGGING
16790     int k;
16791
16792     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
16793     static const char * const anyofs[] = {
16794 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
16795     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6                   \
16796     || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9            \
16797     || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12               \
16798     || _CC_CNTRL != 13 || _CC_ASCII != 14 || _CC_VERTSPACE != 15
16799   #error Need to adjust order of anyofs[]
16800 #endif
16801         "\\w",
16802         "\\W",
16803         "\\d",
16804         "\\D",
16805         "[:alpha:]",
16806         "[:^alpha:]",
16807         "[:lower:]",
16808         "[:^lower:]",
16809         "[:upper:]",
16810         "[:^upper:]",
16811         "[:punct:]",
16812         "[:^punct:]",
16813         "[:print:]",
16814         "[:^print:]",
16815         "[:alnum:]",
16816         "[:^alnum:]",
16817         "[:graph:]",
16818         "[:^graph:]",
16819         "[:cased:]",
16820         "[:^cased:]",
16821         "\\s",
16822         "\\S",
16823         "[:blank:]",
16824         "[:^blank:]",
16825         "[:xdigit:]",
16826         "[:^xdigit:]",
16827         "[:cntrl:]",
16828         "[:^cntrl:]",
16829         "[:ascii:]",
16830         "[:^ascii:]",
16831         "\\v",
16832         "\\V"
16833     };
16834     RXi_GET_DECL(prog,progi);
16835     GET_RE_DEBUG_FLAGS_DECL;
16836
16837     PERL_ARGS_ASSERT_REGPROP;
16838
16839     sv_setpvn(sv, "", 0);
16840
16841     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
16842         /* It would be nice to FAIL() here, but this may be called from
16843            regexec.c, and it would be hard to supply pRExC_state. */
16844         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
16845                                               (int)OP(o), (int)REGNODE_MAX);
16846     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
16847
16848     k = PL_regkind[OP(o)];
16849
16850     if (k == EXACT) {
16851         sv_catpvs(sv, " ");
16852         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
16853          * is a crude hack but it may be the best for now since
16854          * we have no flag "this EXACTish node was UTF-8"
16855          * --jhi */
16856         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
16857                   PERL_PV_ESCAPE_UNI_DETECT |
16858                   PERL_PV_ESCAPE_NONASCII   |
16859                   PERL_PV_PRETTY_ELLIPSES   |
16860                   PERL_PV_PRETTY_LTGT       |
16861                   PERL_PV_PRETTY_NOCLEAR
16862                   );
16863     } else if (k == TRIE) {
16864         /* print the details of the trie in dumpuntil instead, as
16865          * progi->data isn't available here */
16866         const char op = OP(o);
16867         const U32 n = ARG(o);
16868         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
16869                (reg_ac_data *)progi->data->data[n] :
16870                NULL;
16871         const reg_trie_data * const trie
16872             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
16873
16874         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
16875         DEBUG_TRIE_COMPILE_r(
16876           Perl_sv_catpvf(aTHX_ sv,
16877             "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
16878             (UV)trie->startstate,
16879             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
16880             (UV)trie->wordcount,
16881             (UV)trie->minlen,
16882             (UV)trie->maxlen,
16883             (UV)TRIE_CHARCOUNT(trie),
16884             (UV)trie->uniquecharcount
16885           );
16886         );
16887         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
16888             sv_catpvs(sv, "[");
16889             (void) put_charclass_bitmap_innards(sv,
16890                                                 (IS_ANYOF_TRIE(op))
16891                                                  ? ANYOF_BITMAP(o)
16892                                                  : TRIE_BITMAP(trie),
16893                                                 NULL);
16894             sv_catpvs(sv, "]");
16895         }
16896
16897     } else if (k == CURLY) {
16898         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
16899             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
16900         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
16901     }
16902     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
16903         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
16904     else if (k == REF || k == OPEN || k == CLOSE
16905              || k == GROUPP || OP(o)==ACCEPT)
16906     {
16907         AV *name_list= NULL;
16908         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
16909         if ( RXp_PAREN_NAMES(prog) ) {
16910             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
16911         } else if ( pRExC_state ) {
16912             name_list= RExC_paren_name_list;
16913         }
16914         if (name_list) {
16915             if ( k != REF || (OP(o) < NREF)) {
16916                 SV **name= av_fetch(name_list, ARG(o), 0 );
16917                 if (name)
16918                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
16919             }
16920             else {
16921                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
16922                 I32 *nums=(I32*)SvPVX(sv_dat);
16923                 SV **name= av_fetch(name_list, nums[0], 0 );
16924                 I32 n;
16925                 if (name) {
16926                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
16927                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
16928                                     (n ? "," : ""), (IV)nums[n]);
16929                     }
16930                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
16931                 }
16932             }
16933         }
16934         if ( k == REF && reginfo) {
16935             U32 n = ARG(o);  /* which paren pair */
16936             I32 ln = prog->offs[n].start;
16937             if (prog->lastparen < n || ln == -1)
16938                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
16939             else if (ln == prog->offs[n].end)
16940                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
16941             else {
16942                 const char *s = reginfo->strbeg + ln;
16943                 Perl_sv_catpvf(aTHX_ sv, ": ");
16944                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
16945                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
16946             }
16947         }
16948     } else if (k == GOSUB) {
16949         AV *name_list= NULL;
16950         if ( RXp_PAREN_NAMES(prog) ) {
16951             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
16952         } else if ( pRExC_state ) {
16953             name_list= RExC_paren_name_list;
16954         }
16955
16956         /* Paren and offset */
16957         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o));
16958         if (name_list) {
16959             SV **name= av_fetch(name_list, ARG(o), 0 );
16960             if (name)
16961                 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
16962         }
16963     }
16964     else if (k == VERB) {
16965         if (!o->flags)
16966             Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
16967                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
16968     } else if (k == LOGICAL)
16969         /* 2: embedded, otherwise 1 */
16970         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
16971     else if (k == ANYOF) {
16972         const U8 flags = ANYOF_FLAGS(o);
16973         int do_sep = 0;
16974         SV* bitmap_invlist;  /* Will hold what the bit map contains */
16975
16976
16977         if (OP(o) == ANYOFL)
16978             sv_catpvs(sv, "{loc}");
16979         if (flags & ANYOF_LOC_FOLD)
16980             sv_catpvs(sv, "{i}");
16981         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
16982         if (flags & ANYOF_INVERT)
16983             sv_catpvs(sv, "^");
16984
16985         /* output what the standard cp 0-NUM_ANYOF_CODE_POINTS-1 bitmap matches
16986          * */
16987         do_sep = put_charclass_bitmap_innards(sv, ANYOF_BITMAP(o),
16988                                                             &bitmap_invlist);
16989
16990         /* output any special charclass tests (used entirely under use
16991          * locale) * */
16992         if (ANYOF_POSIXL_TEST_ANY_SET(o)) {
16993             int i;
16994             for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
16995                 if (ANYOF_POSIXL_TEST(o,i)) {
16996                     sv_catpv(sv, anyofs[i]);
16997                     do_sep = 1;
16998                 }
16999             }
17000         }
17001
17002         if ((flags & (ANYOF_MATCHES_ALL_ABOVE_BITMAP
17003                       |ANYOF_HAS_UTF8_NONBITMAP_MATCHES
17004                       |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES
17005                       |ANYOF_LOC_FOLD)))
17006         {
17007             if (do_sep) {
17008                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
17009                 if (flags & ANYOF_INVERT)
17010                     /*make sure the invert info is in each */
17011                     sv_catpvs(sv, "^");
17012             }
17013
17014             if (flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) {
17015                 sv_catpvs(sv, "{non-utf8-latin1-all}");
17016             }
17017
17018             if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP)
17019                 sv_catpvs(sv, "{above_bitmap_all}");
17020
17021             if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
17022                 SV *lv; /* Set if there is something outside the bit map. */
17023                 bool byte_output = FALSE;   /* If something has been output */
17024                 SV *only_utf8_locale;
17025
17026                 /* Get the stuff that wasn't in the bitmap.  'bitmap_invlist'
17027                  * is used to guarantee that nothing in the bitmap gets
17028                  * returned */
17029                 (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
17030                                                     &lv, &only_utf8_locale,
17031                                                     bitmap_invlist);
17032                 if (lv && lv != &PL_sv_undef) {
17033                     char *s = savesvpv(lv);
17034                     char * const origs = s;
17035
17036                     while (*s && *s != '\n')
17037                         s++;
17038
17039                     if (*s == '\n') {
17040                         const char * const t = ++s;
17041
17042                         if (flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES) {
17043                             sv_catpvs(sv, "{outside bitmap}");
17044                         }
17045                         else {
17046                             sv_catpvs(sv, "{utf8}");
17047                         }
17048
17049                         if (byte_output) {
17050                             sv_catpvs(sv, " ");
17051                         }
17052
17053                         while (*s) {
17054                             if (*s == '\n') {
17055
17056                                 /* Truncate very long output */
17057                                 if (s - origs > 256) {
17058                                     Perl_sv_catpvf(aTHX_ sv,
17059                                                 "%.*s...",
17060                                                 (int) (s - origs - 1),
17061                                                 t);
17062                                     goto out_dump;
17063                                 }
17064                                 *s = ' ';
17065                             }
17066                             else if (*s == '\t') {
17067                                 *s = '-';
17068                             }
17069                             s++;
17070                         }
17071                         if (s[-1] == ' ')
17072                             s[-1] = 0;
17073
17074                         sv_catpv(sv, t);
17075                     }
17076
17077                   out_dump:
17078
17079                     Safefree(origs);
17080                     SvREFCNT_dec_NN(lv);
17081                 }
17082
17083                 if ((flags & ANYOF_LOC_FOLD)
17084                      && only_utf8_locale
17085                      && only_utf8_locale != &PL_sv_undef)
17086                 {
17087                     UV start, end;
17088                     int max_entries = 256;
17089
17090                     sv_catpvs(sv, "{utf8 locale}");
17091                     invlist_iterinit(only_utf8_locale);
17092                     while (invlist_iternext(only_utf8_locale,
17093                                             &start, &end)) {
17094                         put_range(sv, start, end, FALSE);
17095                         max_entries --;
17096                         if (max_entries < 0) {
17097                             sv_catpvs(sv, "...");
17098                             break;
17099                         }
17100                     }
17101                     invlist_iterfinish(only_utf8_locale);
17102                 }
17103             }
17104         }
17105         SvREFCNT_dec(bitmap_invlist);
17106
17107
17108         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
17109     }
17110     else if (k == POSIXD || k == NPOSIXD) {
17111         U8 index = FLAGS(o) * 2;
17112         if (index < C_ARRAY_LENGTH(anyofs)) {
17113             if (*anyofs[index] != '[')  {
17114                 sv_catpv(sv, "[");
17115             }
17116             sv_catpv(sv, anyofs[index]);
17117             if (*anyofs[index] != '[')  {
17118                 sv_catpv(sv, "]");
17119             }
17120         }
17121         else {
17122             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
17123         }
17124     }
17125     else if (k == BOUND || k == NBOUND) {
17126         /* Must be synced with order of 'bound_type' in regcomp.h */
17127         const char * const bounds[] = {
17128             "",      /* Traditional */
17129             "{gcb}",
17130             "{sb}",
17131             "{wb}"
17132         };
17133         sv_catpv(sv, bounds[FLAGS(o)]);
17134     }
17135     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
17136         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
17137     else if (OP(o) == SBOL)
17138         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
17139 #else
17140     PERL_UNUSED_CONTEXT;
17141     PERL_UNUSED_ARG(sv);
17142     PERL_UNUSED_ARG(o);
17143     PERL_UNUSED_ARG(prog);
17144     PERL_UNUSED_ARG(reginfo);
17145     PERL_UNUSED_ARG(pRExC_state);
17146 #endif  /* DEBUGGING */
17147 }
17148
17149
17150
17151 SV *
17152 Perl_re_intuit_string(pTHX_ REGEXP * const r)
17153 {                               /* Assume that RE_INTUIT is set */
17154     struct regexp *const prog = ReANY(r);
17155     GET_RE_DEBUG_FLAGS_DECL;
17156
17157     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
17158     PERL_UNUSED_CONTEXT;
17159
17160     DEBUG_COMPILE_r(
17161         {
17162             const char * const s = SvPV_nolen_const(RX_UTF8(r)
17163                       ? prog->check_utf8 : prog->check_substr);
17164
17165             if (!PL_colorset) reginitcolors();
17166             PerlIO_printf(Perl_debug_log,
17167                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
17168                       PL_colors[4],
17169                       RX_UTF8(r) ? "utf8 " : "",
17170                       PL_colors[5],PL_colors[0],
17171                       s,
17172                       PL_colors[1],
17173                       (strlen(s) > 60 ? "..." : ""));
17174         } );
17175
17176     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
17177     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
17178 }
17179
17180 /*
17181    pregfree()
17182
17183    handles refcounting and freeing the perl core regexp structure. When
17184    it is necessary to actually free the structure the first thing it
17185    does is call the 'free' method of the regexp_engine associated to
17186    the regexp, allowing the handling of the void *pprivate; member
17187    first. (This routine is not overridable by extensions, which is why
17188    the extensions free is called first.)
17189
17190    See regdupe and regdupe_internal if you change anything here.
17191 */
17192 #ifndef PERL_IN_XSUB_RE
17193 void
17194 Perl_pregfree(pTHX_ REGEXP *r)
17195 {
17196     SvREFCNT_dec(r);
17197 }
17198
17199 void
17200 Perl_pregfree2(pTHX_ REGEXP *rx)
17201 {
17202     struct regexp *const r = ReANY(rx);
17203     GET_RE_DEBUG_FLAGS_DECL;
17204
17205     PERL_ARGS_ASSERT_PREGFREE2;
17206
17207     if (r->mother_re) {
17208         ReREFCNT_dec(r->mother_re);
17209     } else {
17210         CALLREGFREE_PVT(rx); /* free the private data */
17211         SvREFCNT_dec(RXp_PAREN_NAMES(r));
17212         Safefree(r->xpv_len_u.xpvlenu_pv);
17213     }
17214     if (r->substrs) {
17215         SvREFCNT_dec(r->anchored_substr);
17216         SvREFCNT_dec(r->anchored_utf8);
17217         SvREFCNT_dec(r->float_substr);
17218         SvREFCNT_dec(r->float_utf8);
17219         Safefree(r->substrs);
17220     }
17221     RX_MATCH_COPY_FREE(rx);
17222 #ifdef PERL_ANY_COW
17223     SvREFCNT_dec(r->saved_copy);
17224 #endif
17225     Safefree(r->offs);
17226     SvREFCNT_dec(r->qr_anoncv);
17227     rx->sv_u.svu_rx = 0;
17228 }
17229
17230 /*  reg_temp_copy()
17231
17232     This is a hacky workaround to the structural issue of match results
17233     being stored in the regexp structure which is in turn stored in
17234     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
17235     could be PL_curpm in multiple contexts, and could require multiple
17236     result sets being associated with the pattern simultaneously, such
17237     as when doing a recursive match with (??{$qr})
17238
17239     The solution is to make a lightweight copy of the regexp structure
17240     when a qr// is returned from the code executed by (??{$qr}) this
17241     lightweight copy doesn't actually own any of its data except for
17242     the starp/end and the actual regexp structure itself.
17243
17244 */
17245
17246
17247 REGEXP *
17248 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
17249 {
17250     struct regexp *ret;
17251     struct regexp *const r = ReANY(rx);
17252     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
17253
17254     PERL_ARGS_ASSERT_REG_TEMP_COPY;
17255
17256     if (!ret_x)
17257         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
17258     else {
17259         SvOK_off((SV *)ret_x);
17260         if (islv) {
17261             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
17262                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
17263                made both spots point to the same regexp body.) */
17264             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
17265             assert(!SvPVX(ret_x));
17266             ret_x->sv_u.svu_rx = temp->sv_any;
17267             temp->sv_any = NULL;
17268             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
17269             SvREFCNT_dec_NN(temp);
17270             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
17271                ing below will not set it. */
17272             SvCUR_set(ret_x, SvCUR(rx));
17273         }
17274     }
17275     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
17276        sv_force_normal(sv) is called.  */
17277     SvFAKE_on(ret_x);
17278     ret = ReANY(ret_x);
17279
17280     SvFLAGS(ret_x) |= SvUTF8(rx);
17281     /* We share the same string buffer as the original regexp, on which we
17282        hold a reference count, incremented when mother_re is set below.
17283        The string pointer is copied here, being part of the regexp struct.
17284      */
17285     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
17286            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
17287     if (r->offs) {
17288         const I32 npar = r->nparens+1;
17289         Newx(ret->offs, npar, regexp_paren_pair);
17290         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
17291     }
17292     if (r->substrs) {
17293         Newx(ret->substrs, 1, struct reg_substr_data);
17294         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
17295
17296         SvREFCNT_inc_void(ret->anchored_substr);
17297         SvREFCNT_inc_void(ret->anchored_utf8);
17298         SvREFCNT_inc_void(ret->float_substr);
17299         SvREFCNT_inc_void(ret->float_utf8);
17300
17301         /* check_substr and check_utf8, if non-NULL, point to either their
17302            anchored or float namesakes, and don't hold a second reference.  */
17303     }
17304     RX_MATCH_COPIED_off(ret_x);
17305 #ifdef PERL_ANY_COW
17306     ret->saved_copy = NULL;
17307 #endif
17308     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
17309     SvREFCNT_inc_void(ret->qr_anoncv);
17310
17311     return ret_x;
17312 }
17313 #endif
17314
17315 /* regfree_internal()
17316
17317    Free the private data in a regexp. This is overloadable by
17318    extensions. Perl takes care of the regexp structure in pregfree(),
17319    this covers the *pprivate pointer which technically perl doesn't
17320    know about, however of course we have to handle the
17321    regexp_internal structure when no extension is in use.
17322
17323    Note this is called before freeing anything in the regexp
17324    structure.
17325  */
17326
17327 void
17328 Perl_regfree_internal(pTHX_ REGEXP * const rx)
17329 {
17330     struct regexp *const r = ReANY(rx);
17331     RXi_GET_DECL(r,ri);
17332     GET_RE_DEBUG_FLAGS_DECL;
17333
17334     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
17335
17336     DEBUG_COMPILE_r({
17337         if (!PL_colorset)
17338             reginitcolors();
17339         {
17340             SV *dsv= sv_newmortal();
17341             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
17342                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
17343             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
17344                 PL_colors[4],PL_colors[5],s);
17345         }
17346     });
17347 #ifdef RE_TRACK_PATTERN_OFFSETS
17348     if (ri->u.offsets)
17349         Safefree(ri->u.offsets);             /* 20010421 MJD */
17350 #endif
17351     if (ri->code_blocks) {
17352         int n;
17353         for (n = 0; n < ri->num_code_blocks; n++)
17354             SvREFCNT_dec(ri->code_blocks[n].src_regex);
17355         Safefree(ri->code_blocks);
17356     }
17357
17358     if (ri->data) {
17359         int n = ri->data->count;
17360
17361         while (--n >= 0) {
17362           /* If you add a ->what type here, update the comment in regcomp.h */
17363             switch (ri->data->what[n]) {
17364             case 'a':
17365             case 'r':
17366             case 's':
17367             case 'S':
17368             case 'u':
17369                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
17370                 break;
17371             case 'f':
17372                 Safefree(ri->data->data[n]);
17373                 break;
17374             case 'l':
17375             case 'L':
17376                 break;
17377             case 'T':
17378                 { /* Aho Corasick add-on structure for a trie node.
17379                      Used in stclass optimization only */
17380                     U32 refcount;
17381                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
17382 #ifdef USE_ITHREADS
17383                     dVAR;
17384 #endif
17385                     OP_REFCNT_LOCK;
17386                     refcount = --aho->refcount;
17387                     OP_REFCNT_UNLOCK;
17388                     if ( !refcount ) {
17389                         PerlMemShared_free(aho->states);
17390                         PerlMemShared_free(aho->fail);
17391                          /* do this last!!!! */
17392                         PerlMemShared_free(ri->data->data[n]);
17393                         /* we should only ever get called once, so
17394                          * assert as much, and also guard the free
17395                          * which /might/ happen twice. At the least
17396                          * it will make code anlyzers happy and it
17397                          * doesn't cost much. - Yves */
17398                         assert(ri->regstclass);
17399                         if (ri->regstclass) {
17400                             PerlMemShared_free(ri->regstclass);
17401                             ri->regstclass = 0;
17402                         }
17403                     }
17404                 }
17405                 break;
17406             case 't':
17407                 {
17408                     /* trie structure. */
17409                     U32 refcount;
17410                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
17411 #ifdef USE_ITHREADS
17412                     dVAR;
17413 #endif
17414                     OP_REFCNT_LOCK;
17415                     refcount = --trie->refcount;
17416                     OP_REFCNT_UNLOCK;
17417                     if ( !refcount ) {
17418                         PerlMemShared_free(trie->charmap);
17419                         PerlMemShared_free(trie->states);
17420                         PerlMemShared_free(trie->trans);
17421                         if (trie->bitmap)
17422                             PerlMemShared_free(trie->bitmap);
17423                         if (trie->jump)
17424                             PerlMemShared_free(trie->jump);
17425                         PerlMemShared_free(trie->wordinfo);
17426                         /* do this last!!!! */
17427                         PerlMemShared_free(ri->data->data[n]);
17428                     }
17429                 }
17430                 break;
17431             default:
17432                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
17433                                                     ri->data->what[n]);
17434             }
17435         }
17436         Safefree(ri->data->what);
17437         Safefree(ri->data);
17438     }
17439
17440     Safefree(ri);
17441 }
17442
17443 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
17444 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
17445 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
17446
17447 /*
17448    re_dup - duplicate a regexp.
17449
17450    This routine is expected to clone a given regexp structure. It is only
17451    compiled under USE_ITHREADS.
17452
17453    After all of the core data stored in struct regexp is duplicated
17454    the regexp_engine.dupe method is used to copy any private data
17455    stored in the *pprivate pointer. This allows extensions to handle
17456    any duplication it needs to do.
17457
17458    See pregfree() and regfree_internal() if you change anything here.
17459 */
17460 #if defined(USE_ITHREADS)
17461 #ifndef PERL_IN_XSUB_RE
17462 void
17463 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
17464 {
17465     dVAR;
17466     I32 npar;
17467     const struct regexp *r = ReANY(sstr);
17468     struct regexp *ret = ReANY(dstr);
17469
17470     PERL_ARGS_ASSERT_RE_DUP_GUTS;
17471
17472     npar = r->nparens+1;
17473     Newx(ret->offs, npar, regexp_paren_pair);
17474     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
17475
17476     if (ret->substrs) {
17477         /* Do it this way to avoid reading from *r after the StructCopy().
17478            That way, if any of the sv_dup_inc()s dislodge *r from the L1
17479            cache, it doesn't matter.  */
17480         const bool anchored = r->check_substr
17481             ? r->check_substr == r->anchored_substr
17482             : r->check_utf8 == r->anchored_utf8;
17483         Newx(ret->substrs, 1, struct reg_substr_data);
17484         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
17485
17486         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
17487         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
17488         ret->float_substr = sv_dup_inc(ret->float_substr, param);
17489         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
17490
17491         /* check_substr and check_utf8, if non-NULL, point to either their
17492            anchored or float namesakes, and don't hold a second reference.  */
17493
17494         if (ret->check_substr) {
17495             if (anchored) {
17496                 assert(r->check_utf8 == r->anchored_utf8);
17497                 ret->check_substr = ret->anchored_substr;
17498                 ret->check_utf8 = ret->anchored_utf8;
17499             } else {
17500                 assert(r->check_substr == r->float_substr);
17501                 assert(r->check_utf8 == r->float_utf8);
17502                 ret->check_substr = ret->float_substr;
17503                 ret->check_utf8 = ret->float_utf8;
17504             }
17505         } else if (ret->check_utf8) {
17506             if (anchored) {
17507                 ret->check_utf8 = ret->anchored_utf8;
17508             } else {
17509                 ret->check_utf8 = ret->float_utf8;
17510             }
17511         }
17512     }
17513
17514     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
17515     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
17516
17517     if (ret->pprivate)
17518         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
17519
17520     if (RX_MATCH_COPIED(dstr))
17521         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
17522     else
17523         ret->subbeg = NULL;
17524 #ifdef PERL_ANY_COW
17525     ret->saved_copy = NULL;
17526 #endif
17527
17528     /* Whether mother_re be set or no, we need to copy the string.  We
17529        cannot refrain from copying it when the storage points directly to
17530        our mother regexp, because that's
17531                1: a buffer in a different thread
17532                2: something we no longer hold a reference on
17533                so we need to copy it locally.  */
17534     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
17535     ret->mother_re   = NULL;
17536 }
17537 #endif /* PERL_IN_XSUB_RE */
17538
17539 /*
17540    regdupe_internal()
17541
17542    This is the internal complement to regdupe() which is used to copy
17543    the structure pointed to by the *pprivate pointer in the regexp.
17544    This is the core version of the extension overridable cloning hook.
17545    The regexp structure being duplicated will be copied by perl prior
17546    to this and will be provided as the regexp *r argument, however
17547    with the /old/ structures pprivate pointer value. Thus this routine
17548    may override any copying normally done by perl.
17549
17550    It returns a pointer to the new regexp_internal structure.
17551 */
17552
17553 void *
17554 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
17555 {
17556     dVAR;
17557     struct regexp *const r = ReANY(rx);
17558     regexp_internal *reti;
17559     int len;
17560     RXi_GET_DECL(r,ri);
17561
17562     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
17563
17564     len = ProgLen(ri);
17565
17566     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
17567           char, regexp_internal);
17568     Copy(ri->program, reti->program, len+1, regnode);
17569
17570     reti->num_code_blocks = ri->num_code_blocks;
17571     if (ri->code_blocks) {
17572         int n;
17573         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
17574                 struct reg_code_block);
17575         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
17576                 struct reg_code_block);
17577         for (n = 0; n < ri->num_code_blocks; n++)
17578              reti->code_blocks[n].src_regex = (REGEXP*)
17579                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
17580     }
17581     else
17582         reti->code_blocks = NULL;
17583
17584     reti->regstclass = NULL;
17585
17586     if (ri->data) {
17587         struct reg_data *d;
17588         const int count = ri->data->count;
17589         int i;
17590
17591         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
17592                 char, struct reg_data);
17593         Newx(d->what, count, U8);
17594
17595         d->count = count;
17596         for (i = 0; i < count; i++) {
17597             d->what[i] = ri->data->what[i];
17598             switch (d->what[i]) {
17599                 /* see also regcomp.h and regfree_internal() */
17600             case 'a': /* actually an AV, but the dup function is identical.  */
17601             case 'r':
17602             case 's':
17603             case 'S':
17604             case 'u': /* actually an HV, but the dup function is identical.  */
17605                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
17606                 break;
17607             case 'f':
17608                 /* This is cheating. */
17609                 Newx(d->data[i], 1, regnode_ssc);
17610                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
17611                 reti->regstclass = (regnode*)d->data[i];
17612                 break;
17613             case 'T':
17614                 /* Trie stclasses are readonly and can thus be shared
17615                  * without duplication. We free the stclass in pregfree
17616                  * when the corresponding reg_ac_data struct is freed.
17617                  */
17618                 reti->regstclass= ri->regstclass;
17619                 /* FALLTHROUGH */
17620             case 't':
17621                 OP_REFCNT_LOCK;
17622                 ((reg_trie_data*)ri->data->data[i])->refcount++;
17623                 OP_REFCNT_UNLOCK;
17624                 /* FALLTHROUGH */
17625             case 'l':
17626             case 'L':
17627                 d->data[i] = ri->data->data[i];
17628                 break;
17629             default:
17630                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'",
17631                                                            ri->data->what[i]);
17632             }
17633         }
17634
17635         reti->data = d;
17636     }
17637     else
17638         reti->data = NULL;
17639
17640     reti->name_list_idx = ri->name_list_idx;
17641
17642 #ifdef RE_TRACK_PATTERN_OFFSETS
17643     if (ri->u.offsets) {
17644         Newx(reti->u.offsets, 2*len+1, U32);
17645         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
17646     }
17647 #else
17648     SetProgLen(reti,len);
17649 #endif
17650
17651     return (void*)reti;
17652 }
17653
17654 #endif    /* USE_ITHREADS */
17655
17656 #ifndef PERL_IN_XSUB_RE
17657
17658 /*
17659  - regnext - dig the "next" pointer out of a node
17660  */
17661 regnode *
17662 Perl_regnext(pTHX_ regnode *p)
17663 {
17664     I32 offset;
17665
17666     if (!p)
17667         return(NULL);
17668
17669     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
17670         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
17671                                                 (int)OP(p), (int)REGNODE_MAX);
17672     }
17673
17674     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
17675     if (offset == 0)
17676         return(NULL);
17677
17678     return(p+offset);
17679 }
17680 #endif
17681
17682 STATIC void
17683 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
17684 {
17685     va_list args;
17686     STRLEN l1 = strlen(pat1);
17687     STRLEN l2 = strlen(pat2);
17688     char buf[512];
17689     SV *msv;
17690     const char *message;
17691
17692     PERL_ARGS_ASSERT_RE_CROAK2;
17693
17694     if (l1 > 510)
17695         l1 = 510;
17696     if (l1 + l2 > 510)
17697         l2 = 510 - l1;
17698     Copy(pat1, buf, l1 , char);
17699     Copy(pat2, buf + l1, l2 , char);
17700     buf[l1 + l2] = '\n';
17701     buf[l1 + l2 + 1] = '\0';
17702     va_start(args, pat2);
17703     msv = vmess(buf, &args);
17704     va_end(args);
17705     message = SvPV_const(msv,l1);
17706     if (l1 > 512)
17707         l1 = 512;
17708     Copy(message, buf, l1 , char);
17709     /* l1-1 to avoid \n */
17710     Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf));
17711 }
17712
17713 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
17714
17715 #ifndef PERL_IN_XSUB_RE
17716 void
17717 Perl_save_re_context(pTHX)
17718 {
17719     I32 nparens = -1;
17720     I32 i;
17721
17722     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
17723
17724     if (PL_curpm) {
17725         const REGEXP * const rx = PM_GETRE(PL_curpm);
17726         if (rx)
17727             nparens = RX_NPARENS(rx);
17728     }
17729
17730     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
17731      * that PL_curpm will be null, but that utf8.pm and the modules it
17732      * loads will only use $1..$3.
17733      * The t/porting/re_context.t test file checks this assumption.
17734      */
17735     if (nparens == -1)
17736         nparens = 3;
17737
17738     for (i = 1; i <= nparens; i++) {
17739         char digits[TYPE_CHARS(long)];
17740         const STRLEN len = my_snprintf(digits, sizeof(digits),
17741                                        "%lu", (long)i);
17742         GV *const *const gvp
17743             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
17744
17745         if (gvp) {
17746             GV * const gv = *gvp;
17747             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
17748                 save_scalar(gv);
17749         }
17750     }
17751 }
17752 #endif
17753
17754 #ifdef DEBUGGING
17755
17756 STATIC void
17757 S_put_code_point(pTHX_ SV *sv, UV c)
17758 {
17759     PERL_ARGS_ASSERT_PUT_CODE_POINT;
17760
17761     if (c > 255) {
17762         Perl_sv_catpvf(aTHX_ sv, "\\x{%04"UVXf"}", c);
17763     }
17764     else if (isPRINT(c)) {
17765         const char string = (char) c;
17766         if (isBACKSLASHED_PUNCT(c))
17767             sv_catpvs(sv, "\\");
17768         sv_catpvn(sv, &string, 1);
17769     }
17770     else {
17771         const char * const mnemonic = cntrl_to_mnemonic((char) c);
17772         if (mnemonic) {
17773             Perl_sv_catpvf(aTHX_ sv, "%s", mnemonic);
17774         }
17775         else {
17776             Perl_sv_catpvf(aTHX_ sv, "\\x{%02X}", (U8) c);
17777         }
17778     }
17779 }
17780
17781 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
17782
17783 STATIC void
17784 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
17785 {
17786     /* Appends to 'sv' a displayable version of the range of code points from
17787      * 'start' to 'end'.  It assumes that only ASCII printables are displayable
17788      * as-is (though some of these will be escaped by put_code_point()). */
17789
17790     const unsigned int min_range_count = 3;
17791
17792     assert(start <= end);
17793
17794     PERL_ARGS_ASSERT_PUT_RANGE;
17795
17796     while (start <= end) {
17797         UV this_end;
17798         const char * format;
17799
17800         if (end - start < min_range_count) {
17801
17802             /* Individual chars in short ranges */
17803             for (; start <= end; start++) {
17804                 put_code_point(sv, start);
17805             }
17806             break;
17807         }
17808
17809         /* If permitted by the input options, and there is a possibility that
17810          * this range contains a printable literal, look to see if there is
17811          * one.  */
17812         if (allow_literals && start <= MAX_PRINT_A) {
17813
17814             /* If the range begin isn't an ASCII printable, effectively split
17815              * the range into two parts:
17816              *  1) the portion before the first such printable,
17817              *  2) the rest
17818              * and output them separately. */
17819             if (! isPRINT_A(start)) {
17820                 UV temp_end = start + 1;
17821
17822                 /* There is no point looking beyond the final possible
17823                  * printable, in MAX_PRINT_A */
17824                 UV max = MIN(end, MAX_PRINT_A);
17825
17826                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
17827                     temp_end++;
17828                 }
17829
17830                 /* Here, temp_end points to one beyond the first printable if
17831                  * found, or to one beyond 'max' if not.  If none found, make
17832                  * sure that we use the entire range */
17833                 if (temp_end > MAX_PRINT_A) {
17834                     temp_end = end + 1;
17835                 }
17836
17837                 /* Output the first part of the split range, the part that
17838                  * doesn't have printables, with no looking for literals
17839                  * (otherwise we would infinitely recurse) */
17840                 put_range(sv, start, temp_end - 1, FALSE);
17841
17842                 /* The 2nd part of the range (if any) starts here. */
17843                 start = temp_end;
17844
17845                 /* We continue instead of dropping down because even if the 2nd
17846                  * part is non-empty, it could be so short that we want to
17847                  * output it specially, as tested for at the top of this loop.
17848                  * */
17849                 continue;
17850             }
17851
17852             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
17853              * output a sub-range of just the digits or letters, then process
17854              * the remaining portion as usual. */
17855             if (isALPHANUMERIC_A(start)) {
17856                 UV mask = (isDIGIT_A(start))
17857                            ? _CC_DIGIT
17858                              : isUPPER_A(start)
17859                                ? _CC_UPPER
17860                                : _CC_LOWER;
17861                 UV temp_end = start + 1;
17862
17863                 /* Find the end of the sub-range that includes just the
17864                  * characters in the same class as the first character in it */
17865                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
17866                     temp_end++;
17867                 }
17868                 temp_end--;
17869
17870                 /* For short ranges, don't duplicate the code above to output
17871                  * them; just call recursively */
17872                 if (temp_end - start < min_range_count) {
17873                     put_range(sv, start, temp_end, FALSE);
17874                 }
17875                 else {  /* Output as a range */
17876                     put_code_point(sv, start);
17877                     sv_catpvs(sv, "-");
17878                     put_code_point(sv, temp_end);
17879                 }
17880                 start = temp_end + 1;
17881                 continue;
17882             }
17883
17884             /* We output any other printables as individual characters */
17885             if (isPUNCT_A(start) || isSPACE_A(start)) {
17886                 while (start <= end && (isPUNCT_A(start)
17887                                         || isSPACE_A(start)))
17888                 {
17889                     put_code_point(sv, start);
17890                     start++;
17891                 }
17892                 continue;
17893             }
17894         } /* End of looking for literals */
17895
17896         /* Here is not to output as a literal.  Some control characters have
17897          * mnemonic names.  Split off any of those at the beginning and end of
17898          * the range to print mnemonically.  It isn't possible for many of
17899          * these to be in a row, so this won't overwhelm with output */
17900         while (isMNEMONIC_CNTRL(start) && start <= end) {
17901             put_code_point(sv, start);
17902             start++;
17903         }
17904         if (start < end && isMNEMONIC_CNTRL(end)) {
17905
17906             /* Here, the final character in the range has a mnemonic name.
17907              * Work backwards from the end to find the final non-mnemonic */
17908             UV temp_end = end - 1;
17909             while (isMNEMONIC_CNTRL(temp_end)) {
17910                 temp_end--;
17911             }
17912
17913             /* And separately output the range that doesn't have mnemonics */
17914             put_range(sv, start, temp_end, FALSE);
17915
17916             /* Then output the mnemonic trailing controls */
17917             start = temp_end + 1;
17918             while (start <= end) {
17919                 put_code_point(sv, start);
17920                 start++;
17921             }
17922             break;
17923         }
17924
17925         /* As a final resort, output the range or subrange as hex. */
17926
17927         this_end = (end < NUM_ANYOF_CODE_POINTS)
17928                     ? end
17929                     : NUM_ANYOF_CODE_POINTS - 1;
17930         format = (this_end < 256)
17931                  ? "\\x{%02"UVXf"}-\\x{%02"UVXf"}"
17932                  : "\\x{%04"UVXf"}-\\x{%04"UVXf"}";
17933         GCC_DIAG_IGNORE(-Wformat-nonliteral);
17934         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
17935         GCC_DIAG_RESTORE;
17936         break;
17937     }
17938 }
17939
17940 STATIC bool
17941 S_put_charclass_bitmap_innards(pTHX_ SV *sv, char *bitmap, SV** bitmap_invlist)
17942 {
17943     /* Appends to 'sv' a displayable version of the innards of the bracketed
17944      * character class whose bitmap is 'bitmap';  Returns 'TRUE' if it actually
17945      * output anything, and bitmap_invlist, if not NULL, will point to an
17946      * inversion list of what is in the bit map */
17947
17948     int i;
17949     UV start, end;
17950     unsigned int punct_count = 0;
17951     SV* invlist = NULL;
17952     SV** invlist_ptr;   /* Temporary, in case bitmap_invlist is NULL */
17953     bool allow_literals = TRUE;
17954
17955     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
17956
17957     invlist_ptr = (bitmap_invlist) ? bitmap_invlist : &invlist;
17958
17959     /* Worst case is exactly every-other code point is in the list */
17960     *invlist_ptr = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
17961
17962     /* Convert the bit map to an inversion list, keeping track of how many
17963      * ASCII puncts are set, including an extra amount for the backslashed
17964      * ones.  */
17965     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
17966         if (BITMAP_TEST(bitmap, i)) {
17967             *invlist_ptr = add_cp_to_invlist(*invlist_ptr, i);
17968             if (isPUNCT_A(i)) {
17969                 punct_count++;
17970                 if isBACKSLASHED_PUNCT(i) {
17971                     punct_count++;
17972                 }
17973             }
17974         }
17975     }
17976
17977     /* Nothing to output */
17978     if (_invlist_len(*invlist_ptr) == 0) {
17979         SvREFCNT_dec(invlist);
17980         return FALSE;
17981     }
17982
17983     /* Generally, it is more readable if printable characters are output as
17984      * literals, but if a range (nearly) spans all of them, it's best to output
17985      * it as a single range.  This code will use a single range if all but 2
17986      * printables are in it */
17987     invlist_iterinit(*invlist_ptr);
17988     while (invlist_iternext(*invlist_ptr, &start, &end)) {
17989
17990         /* If range starts beyond final printable, it doesn't have any in it */
17991         if (start > MAX_PRINT_A) {
17992             break;
17993         }
17994
17995         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
17996          * all but two, the range must start and end no later than 2 from
17997          * either end */
17998         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
17999             if (end > MAX_PRINT_A) {
18000                 end = MAX_PRINT_A;
18001             }
18002             if (start < ' ') {
18003                 start = ' ';
18004             }
18005             if (end - start >= MAX_PRINT_A - ' ' - 2) {
18006                 allow_literals = FALSE;
18007             }
18008             break;
18009         }
18010     }
18011     invlist_iterfinish(*invlist_ptr);
18012
18013     /* The legibility of the output depends mostly on how many punctuation
18014      * characters are output.  There are 32 possible ASCII ones, and some have
18015      * an additional backslash, bringing it to currently 36, so if any more
18016      * than 18 are to be output, we can instead output it as its complement,
18017      * yielding fewer puncts, and making it more legible.  But give some weight
18018      * to the fact that outputting it as a complement is less legible than a
18019      * straight output, so don't complement unless we are somewhat over the 18
18020      * mark */
18021     if (allow_literals && punct_count > 22) {
18022         sv_catpvs(sv, "^");
18023
18024         /* Add everything remaining to the list, so when we invert it just
18025          * below, it will be excluded */
18026         _invlist_union_complement_2nd(*invlist_ptr, PL_InBitmap, invlist_ptr);
18027         _invlist_invert(*invlist_ptr);
18028     }
18029
18030     /* Here we have figured things out.  Output each range */
18031     invlist_iterinit(*invlist_ptr);
18032     while (invlist_iternext(*invlist_ptr, &start, &end)) {
18033         if (start >= NUM_ANYOF_CODE_POINTS) {
18034             break;
18035         }
18036         put_range(sv, start, end, allow_literals);
18037     }
18038     invlist_iterfinish(*invlist_ptr);
18039
18040     return TRUE;
18041 }
18042
18043 #define CLEAR_OPTSTART \
18044     if (optstart) STMT_START {                                               \
18045         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,                       \
18046                               " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
18047         optstart=NULL;                                                       \
18048     } STMT_END
18049
18050 #define DUMPUNTIL(b,e)                                                       \
18051                     CLEAR_OPTSTART;                                          \
18052                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
18053
18054 STATIC const regnode *
18055 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
18056             const regnode *last, const regnode *plast,
18057             SV* sv, I32 indent, U32 depth)
18058 {
18059     U8 op = PSEUDO;     /* Arbitrary non-END op. */
18060     const regnode *next;
18061     const regnode *optstart= NULL;
18062
18063     RXi_GET_DECL(r,ri);
18064     GET_RE_DEBUG_FLAGS_DECL;
18065
18066     PERL_ARGS_ASSERT_DUMPUNTIL;
18067
18068 #ifdef DEBUG_DUMPUNTIL
18069     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
18070         last ? last-start : 0,plast ? plast-start : 0);
18071 #endif
18072
18073     if (plast && plast < last)
18074         last= plast;
18075
18076     while (PL_regkind[op] != END && (!last || node < last)) {
18077         assert(node);
18078         /* While that wasn't END last time... */
18079         NODE_ALIGN(node);
18080         op = OP(node);
18081         if (op == CLOSE || op == WHILEM)
18082             indent--;
18083         next = regnext((regnode *)node);
18084
18085         /* Where, what. */
18086         if (OP(node) == OPTIMIZED) {
18087             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
18088                 optstart = node;
18089             else
18090                 goto after_print;
18091         } else
18092             CLEAR_OPTSTART;
18093
18094         regprop(r, sv, node, NULL, NULL);
18095         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
18096                       (int)(2*indent + 1), "", SvPVX_const(sv));
18097
18098         if (OP(node) != OPTIMIZED) {
18099             if (next == NULL)           /* Next ptr. */
18100                 PerlIO_printf(Perl_debug_log, " (0)");
18101             else if (PL_regkind[(U8)op] == BRANCH
18102                      && PL_regkind[OP(next)] != BRANCH )
18103                 PerlIO_printf(Perl_debug_log, " (FAIL)");
18104             else
18105                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
18106             (void)PerlIO_putc(Perl_debug_log, '\n');
18107         }
18108
18109       after_print:
18110         if (PL_regkind[(U8)op] == BRANCHJ) {
18111             assert(next);
18112             {
18113                 const regnode *nnode = (OP(next) == LONGJMP
18114                                        ? regnext((regnode *)next)
18115                                        : next);
18116                 if (last && nnode > last)
18117                     nnode = last;
18118                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
18119             }
18120         }
18121         else if (PL_regkind[(U8)op] == BRANCH) {
18122             assert(next);
18123             DUMPUNTIL(NEXTOPER(node), next);
18124         }
18125         else if ( PL_regkind[(U8)op]  == TRIE ) {
18126             const regnode *this_trie = node;
18127             const char op = OP(node);
18128             const U32 n = ARG(node);
18129             const reg_ac_data * const ac = op>=AHOCORASICK ?
18130                (reg_ac_data *)ri->data->data[n] :
18131                NULL;
18132             const reg_trie_data * const trie =
18133                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
18134 #ifdef DEBUGGING
18135             AV *const trie_words
18136                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
18137 #endif
18138             const regnode *nextbranch= NULL;
18139             I32 word_idx;
18140             sv_setpvs(sv, "");
18141             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
18142                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
18143
18144                 PerlIO_printf(Perl_debug_log, "%*s%s ",
18145                    (int)(2*(indent+3)), "",
18146                     elem_ptr
18147                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
18148                                 SvCUR(*elem_ptr), 60,
18149                                 PL_colors[0], PL_colors[1],
18150                                 (SvUTF8(*elem_ptr)
18151                                  ? PERL_PV_ESCAPE_UNI
18152                                  : 0)
18153                                 | PERL_PV_PRETTY_ELLIPSES
18154                                 | PERL_PV_PRETTY_LTGT
18155                             )
18156                     : "???"
18157                 );
18158                 if (trie->jump) {
18159                     U16 dist= trie->jump[word_idx+1];
18160                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
18161                                (UV)((dist ? this_trie + dist : next) - start));
18162                     if (dist) {
18163                         if (!nextbranch)
18164                             nextbranch= this_trie + trie->jump[0];
18165                         DUMPUNTIL(this_trie + dist, nextbranch);
18166                     }
18167                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
18168                         nextbranch= regnext((regnode *)nextbranch);
18169                 } else {
18170                     PerlIO_printf(Perl_debug_log, "\n");
18171                 }
18172             }
18173             if (last && next > last)
18174                 node= last;
18175             else
18176                 node= next;
18177         }
18178         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
18179             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
18180                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
18181         }
18182         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
18183             assert(next);
18184             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
18185         }
18186         else if ( op == PLUS || op == STAR) {
18187             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
18188         }
18189         else if (PL_regkind[(U8)op] == ANYOF) {
18190             /* arglen 1 + class block */
18191             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
18192                           ? ANYOF_POSIXL_SKIP
18193                           : ANYOF_SKIP);
18194             node = NEXTOPER(node);
18195         }
18196         else if (PL_regkind[(U8)op] == EXACT) {
18197             /* Literal string, where present. */
18198             node += NODE_SZ_STR(node) - 1;
18199             node = NEXTOPER(node);
18200         }
18201         else {
18202             node = NEXTOPER(node);
18203             node += regarglen[(U8)op];
18204         }
18205         if (op == CURLYX || op == OPEN)
18206             indent++;
18207     }
18208     CLEAR_OPTSTART;
18209 #ifdef DEBUG_DUMPUNTIL
18210     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
18211 #endif
18212     return node;
18213 }
18214
18215 #endif  /* DEBUGGING */
18216
18217 /*
18218  * ex: set ts=8 sts=4 sw=4 et:
18219  */