This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Reflect next changes in release schedule
[perl5.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #  include "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 EXTERN_C const struct regexp_engine my_reg_engine;
85 #else
86 #  include "regcomp.h"
87 #endif
88
89 #include "dquote_inline.h"
90 #include "invlist_inline.h"
91 #include "unicode_constants.h"
92
93 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
94  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
96  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
97 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
98 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
99
100 #ifndef STATIC
101 #define STATIC  static
102 #endif
103
104 /* this is a chain of data about sub patterns we are processing that
105    need to be handled separately/specially in study_chunk. Its so
106    we can simulate recursion without losing state.  */
107 struct scan_frame;
108 typedef struct scan_frame {
109     regnode *last_regnode;      /* last node to process in this frame */
110     regnode *next_regnode;      /* next node to process when last is reached */
111     U32 prev_recursed_depth;
112     I32 stopparen;              /* what stopparen do we use */
113     U32 is_top_frame;           /* what flags do we use? */
114
115     struct scan_frame *this_prev_frame; /* this previous frame */
116     struct scan_frame *prev_frame;      /* previous frame */
117     struct scan_frame *next_frame;      /* next frame */
118 } scan_frame;
119
120 /* Certain characters are output as a sequence with the first being a
121  * backslash. */
122 #define isBACKSLASHED_PUNCT(c)                                              \
123                     ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
124
125
126 struct RExC_state_t {
127     U32         flags;                  /* RXf_* are we folding, multilining? */
128     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
129     char        *precomp;               /* uncompiled string. */
130     char        *precomp_end;           /* pointer to end of uncompiled string. */
131     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
132     regexp      *rx;                    /* perl core regexp structure */
133     regexp_internal     *rxi;           /* internal data for regexp object
134                                            pprivate field */
135     char        *start;                 /* Start of input for compile */
136     char        *end;                   /* End of input for compile */
137     char        *parse;                 /* Input-scan pointer. */
138     char        *adjusted_start;        /* 'start', adjusted.  See code use */
139     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
140     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
141     regnode     *emit_start;            /* Start of emitted-code area */
142     regnode     *emit_bound;            /* First regnode outside of the
143                                            allocated space */
144     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
145                                            implies compiling, so don't emit */
146     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
147                                            large enough for the largest
148                                            non-EXACTish node, so can use it as
149                                            scratch in pass1 */
150     I32         naughty;                /* How bad is this pattern? */
151     I32         sawback;                /* Did we see \1, ...? */
152     U32         seen;
153     SSize_t     size;                   /* Code size. */
154     I32                npar;            /* Capture buffer count, (OPEN) plus
155                                            one. ("par" 0 is the whole
156                                            pattern)*/
157     I32         nestroot;               /* root parens we are in - used by
158                                            accept */
159     I32         extralen;
160     I32         seen_zerolen;
161     regnode     **open_parens;          /* pointers to open parens */
162     regnode     **close_parens;         /* pointers to close parens */
163     regnode     *end_op;                /* END node in program */
164     I32         utf8;           /* whether the pattern is utf8 or not */
165     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
166                                 /* XXX use this for future optimisation of case
167                                  * where pattern must be upgraded to utf8. */
168     I32         uni_semantics;  /* If a d charset modifier should use unicode
169                                    rules, even if the pattern is not in
170                                    utf8 */
171     HV          *paren_names;           /* Paren names */
172
173     regnode     **recurse;              /* Recurse regops */
174     I32                recurse_count;                /* Number of recurse regops we have generated */
175     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
176                                            through */
177     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
178     I32         in_lookbehind;
179     I32         contains_locale;
180     I32         override_recoding;
181 #ifdef EBCDIC
182     I32         recode_x_to_native;
183 #endif
184     I32         in_multi_char_class;
185     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
186                                             within pattern */
187     int         code_index;             /* next code_blocks[] slot */
188     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
189     scan_frame *frame_head;
190     scan_frame *frame_last;
191     U32         frame_count;
192     AV         *warn_text;
193 #ifdef ADD_TO_REGEXEC
194     char        *starttry;              /* -Dr: where regtry was called. */
195 #define RExC_starttry   (pRExC_state->starttry)
196 #endif
197     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
198 #ifdef DEBUGGING
199     const char  *lastparse;
200     I32         lastnum;
201     AV          *paren_name_list;       /* idx -> name */
202     U32         study_chunk_recursed_count;
203     SV          *mysv1;
204     SV          *mysv2;
205 #define RExC_lastparse  (pRExC_state->lastparse)
206 #define RExC_lastnum    (pRExC_state->lastnum)
207 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
208 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
209 #define RExC_mysv       (pRExC_state->mysv1)
210 #define RExC_mysv1      (pRExC_state->mysv1)
211 #define RExC_mysv2      (pRExC_state->mysv2)
212
213 #endif
214     bool        seen_unfolded_sharp_s;
215     bool        strict;
216     bool        study_started;
217 };
218
219 #define RExC_flags      (pRExC_state->flags)
220 #define RExC_pm_flags   (pRExC_state->pm_flags)
221 #define RExC_precomp    (pRExC_state->precomp)
222 #define RExC_precomp_adj (pRExC_state->precomp_adj)
223 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
224 #define RExC_precomp_end (pRExC_state->precomp_end)
225 #define RExC_rx_sv      (pRExC_state->rx_sv)
226 #define RExC_rx         (pRExC_state->rx)
227 #define RExC_rxi        (pRExC_state->rxi)
228 #define RExC_start      (pRExC_state->start)
229 #define RExC_end        (pRExC_state->end)
230 #define RExC_parse      (pRExC_state->parse)
231 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
232
233 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
234  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
235  * something forces the pattern into using /ui rules, the sharp s should be
236  * folded into the sequence 'ss', which takes up more space than previously
237  * calculated.  This means that the sizing pass needs to be restarted.  (The
238  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
239  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
240  * so there is no need to resize [perl #125990]. */
241 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
242
243 #ifdef RE_TRACK_PATTERN_OFFSETS
244 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
245                                                          others */
246 #endif
247 #define RExC_emit       (pRExC_state->emit)
248 #define RExC_emit_dummy (pRExC_state->emit_dummy)
249 #define RExC_emit_start (pRExC_state->emit_start)
250 #define RExC_emit_bound (pRExC_state->emit_bound)
251 #define RExC_sawback    (pRExC_state->sawback)
252 #define RExC_seen       (pRExC_state->seen)
253 #define RExC_size       (pRExC_state->size)
254 #define RExC_maxlen        (pRExC_state->maxlen)
255 #define RExC_npar       (pRExC_state->npar)
256 #define RExC_nestroot   (pRExC_state->nestroot)
257 #define RExC_extralen   (pRExC_state->extralen)
258 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
259 #define RExC_utf8       (pRExC_state->utf8)
260 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
261 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
262 #define RExC_open_parens        (pRExC_state->open_parens)
263 #define RExC_close_parens       (pRExC_state->close_parens)
264 #define RExC_end_op     (pRExC_state->end_op)
265 #define RExC_paren_names        (pRExC_state->paren_names)
266 #define RExC_recurse    (pRExC_state->recurse)
267 #define RExC_recurse_count      (pRExC_state->recurse_count)
268 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
269 #define RExC_study_chunk_recursed_bytes  \
270                                    (pRExC_state->study_chunk_recursed_bytes)
271 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
272 #define RExC_contains_locale    (pRExC_state->contains_locale)
273 #ifdef EBCDIC
274 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
275 #endif
276 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
277 #define RExC_frame_head (pRExC_state->frame_head)
278 #define RExC_frame_last (pRExC_state->frame_last)
279 #define RExC_frame_count (pRExC_state->frame_count)
280 #define RExC_strict (pRExC_state->strict)
281 #define RExC_study_started      (pRExC_state->study_started)
282 #define RExC_warn_text (pRExC_state->warn_text)
283
284 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
285  * a flag to disable back-off on the fixed/floating substrings - if it's
286  * a high complexity pattern we assume the benefit of avoiding a full match
287  * is worth the cost of checking for the substrings even if they rarely help.
288  */
289 #define RExC_naughty    (pRExC_state->naughty)
290 #define TOO_NAUGHTY (10)
291 #define MARK_NAUGHTY(add) \
292     if (RExC_naughty < TOO_NAUGHTY) \
293         RExC_naughty += (add)
294 #define MARK_NAUGHTY_EXP(exp, add) \
295     if (RExC_naughty < TOO_NAUGHTY) \
296         RExC_naughty += RExC_naughty / (exp) + (add)
297
298 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
299 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
300         ((*s) == '{' && regcurly(s)))
301
302 /*
303  * Flags to be passed up and down.
304  */
305 #define WORST           0       /* Worst case. */
306 #define HASWIDTH        0x01    /* Known to match non-null strings. */
307
308 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
309  * character.  (There needs to be a case: in the switch statement in regexec.c
310  * for any node marked SIMPLE.)  Note that this is not the same thing as
311  * REGNODE_SIMPLE */
312 #define SIMPLE          0x02
313 #define SPSTART         0x04    /* Starts with * or + */
314 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
315 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
316 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
317 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
318                                    calcuate sizes as UTF-8 */
319
320 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
321
322 /* whether trie related optimizations are enabled */
323 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
324 #define TRIE_STUDY_OPT
325 #define FULL_TRIE_STUDY
326 #define TRIE_STCLASS
327 #endif
328
329
330
331 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
332 #define PBITVAL(paren) (1 << ((paren) & 7))
333 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
334 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
335 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
336
337 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
338                                      if (!UTF) {                           \
339                                          assert(PASS1);                    \
340                                          *flagp = RESTART_PASS1|NEED_UTF8; \
341                                          return NULL;                      \
342                                      }                                     \
343                              } STMT_END
344
345 /* Change from /d into /u rules, and restart the parse if we've already seen
346  * something whose size would increase as a result, by setting *flagp and
347  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
348  * we've change to /u during the parse.  */
349 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
350     STMT_START {                                                            \
351             if (DEPENDS_SEMANTICS) {                                        \
352                 assert(PASS1);                                              \
353                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
354                 RExC_uni_semantics = 1;                                     \
355                 if (RExC_seen_unfolded_sharp_s) {                           \
356                     *flagp |= RESTART_PASS1;                                \
357                     return restart_retval;                                  \
358                 }                                                           \
359             }                                                               \
360     } STMT_END
361
362 /* This converts the named class defined in regcomp.h to its equivalent class
363  * number defined in handy.h. */
364 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
365 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
366
367 #define _invlist_union_complement_2nd(a, b, output) \
368                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
369 #define _invlist_intersection_complement_2nd(a, b, output) \
370                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
371
372 /* About scan_data_t.
373
374   During optimisation we recurse through the regexp program performing
375   various inplace (keyhole style) optimisations. In addition study_chunk
376   and scan_commit populate this data structure with information about
377   what strings MUST appear in the pattern. We look for the longest
378   string that must appear at a fixed location, and we look for the
379   longest string that may appear at a floating location. So for instance
380   in the pattern:
381
382     /FOO[xX]A.*B[xX]BAR/
383
384   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
385   strings (because they follow a .* construct). study_chunk will identify
386   both FOO and BAR as being the longest fixed and floating strings respectively.
387
388   The strings can be composites, for instance
389
390      /(f)(o)(o)/
391
392   will result in a composite fixed substring 'foo'.
393
394   For each string some basic information is maintained:
395
396   - offset or min_offset
397     This is the position the string must appear at, or not before.
398     It also implicitly (when combined with minlenp) tells us how many
399     characters must match before the string we are searching for.
400     Likewise when combined with minlenp and the length of the string it
401     tells us how many characters must appear after the string we have
402     found.
403
404   - max_offset
405     Only used for floating strings. This is the rightmost point that
406     the string can appear at. If set to SSize_t_MAX it indicates that the
407     string can occur infinitely far to the right.
408
409   - minlenp
410     A pointer to the minimum number of characters of the pattern that the
411     string was found inside. This is important as in the case of positive
412     lookahead or positive lookbehind we can have multiple patterns
413     involved. Consider
414
415     /(?=FOO).*F/
416
417     The minimum length of the pattern overall is 3, the minimum length
418     of the lookahead part is 3, but the minimum length of the part that
419     will actually match is 1. So 'FOO's minimum length is 3, but the
420     minimum length for the F is 1. This is important as the minimum length
421     is used to determine offsets in front of and behind the string being
422     looked for.  Since strings can be composites this is the length of the
423     pattern at the time it was committed with a scan_commit. Note that
424     the length is calculated by study_chunk, so that the minimum lengths
425     are not known until the full pattern has been compiled, thus the
426     pointer to the value.
427
428   - lookbehind
429
430     In the case of lookbehind the string being searched for can be
431     offset past the start point of the final matching string.
432     If this value was just blithely removed from the min_offset it would
433     invalidate some of the calculations for how many chars must match
434     before or after (as they are derived from min_offset and minlen and
435     the length of the string being searched for).
436     When the final pattern is compiled and the data is moved from the
437     scan_data_t structure into the regexp structure the information
438     about lookbehind is factored in, with the information that would
439     have been lost precalculated in the end_shift field for the
440     associated string.
441
442   The fields pos_min and pos_delta are used to store the minimum offset
443   and the delta to the maximum offset at the current point in the pattern.
444
445 */
446
447 typedef struct scan_data_t {
448     /*I32 len_min;      unused */
449     /*I32 len_delta;    unused */
450     SSize_t pos_min;
451     SSize_t pos_delta;
452     SV *last_found;
453     SSize_t last_end;       /* min value, <0 unless valid. */
454     SSize_t last_start_min;
455     SSize_t last_start_max;
456     SV **longest;           /* Either &l_fixed, or &l_float. */
457     SV *longest_fixed;      /* longest fixed string found in pattern */
458     SSize_t offset_fixed;   /* offset where it starts */
459     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
460     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
461     SV *longest_float;      /* longest floating string found in pattern */
462     SSize_t offset_float_min; /* earliest point in string it can appear */
463     SSize_t offset_float_max; /* latest point in string it can appear */
464     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
465     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
466     I32 flags;
467     I32 whilem_c;
468     SSize_t *last_closep;
469     regnode_ssc *start_class;
470 } scan_data_t;
471
472 /*
473  * Forward declarations for pregcomp()'s friends.
474  */
475
476 static const scan_data_t zero_scan_data =
477   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
478
479 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
480 #define SF_BEFORE_SEOL          0x0001
481 #define SF_BEFORE_MEOL          0x0002
482 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
483 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
484
485 #define SF_FIX_SHIFT_EOL        (+2)
486 #define SF_FL_SHIFT_EOL         (+4)
487
488 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
489 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
490
491 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
492 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
493 #define SF_IS_INF               0x0040
494 #define SF_HAS_PAR              0x0080
495 #define SF_IN_PAR               0x0100
496 #define SF_HAS_EVAL             0x0200
497
498
499 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
500  * longest substring in the pattern. When it is not set the optimiser keeps
501  * track of position, but does not keep track of the actual strings seen,
502  *
503  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
504  * /foo/i will not.
505  *
506  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
507  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
508  * turned off because of the alternation (BRANCH). */
509 #define SCF_DO_SUBSTR           0x0400
510
511 #define SCF_DO_STCLASS_AND      0x0800
512 #define SCF_DO_STCLASS_OR       0x1000
513 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
514 #define SCF_WHILEM_VISITED_POS  0x2000
515
516 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
517 #define SCF_SEEN_ACCEPT         0x8000
518 #define SCF_TRIE_DOING_RESTUDY 0x10000
519 #define SCF_IN_DEFINE          0x20000
520
521
522
523
524 #define UTF cBOOL(RExC_utf8)
525
526 /* The enums for all these are ordered so things work out correctly */
527 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
528 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
529                                                      == REGEX_DEPENDS_CHARSET)
530 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
531 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
532                                                      >= REGEX_UNICODE_CHARSET)
533 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
534                                             == REGEX_ASCII_RESTRICTED_CHARSET)
535 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
536                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
537 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
538                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
539
540 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
541
542 /* For programs that want to be strictly Unicode compatible by dying if any
543  * attempt is made to match a non-Unicode code point against a Unicode
544  * property.  */
545 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
546
547 #define OOB_NAMEDCLASS          -1
548
549 /* There is no code point that is out-of-bounds, so this is problematic.  But
550  * its only current use is to initialize a variable that is always set before
551  * looked at. */
552 #define OOB_UNICODE             0xDEADBEEF
553
554 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
555
556
557 /* length of regex to show in messages that don't mark a position within */
558 #define RegexLengthToShowInErrorMessages 127
559
560 /*
561  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
562  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
563  * op/pragma/warn/regcomp.
564  */
565 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
566 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
567
568 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
569                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
570
571 /* The code in this file in places uses one level of recursion with parsing
572  * rebased to an alternate string constructed by us in memory.  This can take
573  * the form of something that is completely different from the input, or
574  * something that uses the input as part of the alternate.  In the first case,
575  * there should be no possibility of an error, as we are in complete control of
576  * the alternate string.  But in the second case we don't control the input
577  * portion, so there may be errors in that.  Here's an example:
578  *      /[abc\x{DF}def]/ui
579  * is handled specially because \x{df} folds to a sequence of more than one
580  * character, 'ss'.  What is done is to create and parse an alternate string,
581  * which looks like this:
582  *      /(?:\x{DF}|[abc\x{DF}def])/ui
583  * where it uses the input unchanged in the middle of something it constructs,
584  * which is a branch for the DF outside the character class, and clustering
585  * parens around the whole thing. (It knows enough to skip the DF inside the
586  * class while in this substitute parse.) 'abc' and 'def' may have errors that
587  * need to be reported.  The general situation looks like this:
588  *
589  *              sI                       tI               xI       eI
590  * Input:       ----------------------------------------------------
591  * Constructed:         ---------------------------------------------------
592  *                      sC               tC               xC       eC     EC
593  *
594  * The input string sI..eI is the input pattern.  The string sC..EC is the
595  * constructed substitute parse string.  The portions sC..tC and eC..EC are
596  * constructed by us.  The portion tC..eC is an exact duplicate of the input
597  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
598  * while parsing, we find an error at xC.  We want to display a message showing
599  * the real input string.  Thus we need to find the point xI in it which
600  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
601  * been constructed by us, and so shouldn't have errors.  We get:
602  *
603  *      xI = sI + (tI - sI) + (xC - tC)
604  *
605  * and, the offset into sI is:
606  *
607  *      (xI - sI) = (tI - sI) + (xC - tC)
608  *
609  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
610  * and we save tC as RExC_adjusted_start.
611  *
612  * During normal processing of the input pattern, everything points to that,
613  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
614  */
615
616 #define tI_sI           RExC_precomp_adj
617 #define tC              RExC_adjusted_start
618 #define sC              RExC_precomp
619 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
620 #define xI(xC)          (sC + xI_offset(xC))
621 #define eC              RExC_precomp_end
622
623 #define REPORT_LOCATION_ARGS(xC)                                            \
624     UTF8fARG(UTF,                                                           \
625              (xI(xC) > eC) /* Don't run off end */                          \
626               ? eC - sC   /* Length before the <--HERE */                   \
627               : xI_offset(xC),                                              \
628              sC),         /* The input pattern printed up to the <--HERE */ \
629     UTF8fARG(UTF,                                                           \
630              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
631              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
632
633 /* Used to point after bad bytes for an error message, but avoid skipping
634  * past a nul byte. */
635 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
636
637 /*
638  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
639  * arg. Show regex, up to a maximum length. If it's too long, chop and add
640  * "...".
641  */
642 #define _FAIL(code) STMT_START {                                        \
643     const char *ellipses = "";                                          \
644     IV len = RExC_precomp_end - RExC_precomp;                                   \
645                                                                         \
646     if (!SIZE_ONLY)                                                     \
647         SAVEFREESV(RExC_rx_sv);                                         \
648     if (len > RegexLengthToShowInErrorMessages) {                       \
649         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
650         len = RegexLengthToShowInErrorMessages - 10;                    \
651         ellipses = "...";                                               \
652     }                                                                   \
653     code;                                                               \
654 } STMT_END
655
656 #define FAIL(msg) _FAIL(                            \
657     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
658             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
659
660 #define FAIL2(msg,arg) _FAIL(                       \
661     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
662             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
663
664 /*
665  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
666  */
667 #define Simple_vFAIL(m) STMT_START {                                    \
668     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
669             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
670 } STMT_END
671
672 /*
673  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
674  */
675 #define vFAIL(m) STMT_START {                           \
676     if (!SIZE_ONLY)                                     \
677         SAVEFREESV(RExC_rx_sv);                         \
678     Simple_vFAIL(m);                                    \
679 } STMT_END
680
681 /*
682  * Like Simple_vFAIL(), but accepts two arguments.
683  */
684 #define Simple_vFAIL2(m,a1) STMT_START {                        \
685     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
686                       REPORT_LOCATION_ARGS(RExC_parse));        \
687 } STMT_END
688
689 /*
690  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
691  */
692 #define vFAIL2(m,a1) STMT_START {                       \
693     if (!SIZE_ONLY)                                     \
694         SAVEFREESV(RExC_rx_sv);                         \
695     Simple_vFAIL2(m, a1);                               \
696 } STMT_END
697
698
699 /*
700  * Like Simple_vFAIL(), but accepts three arguments.
701  */
702 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
703     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
704             REPORT_LOCATION_ARGS(RExC_parse));                  \
705 } STMT_END
706
707 /*
708  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
709  */
710 #define vFAIL3(m,a1,a2) STMT_START {                    \
711     if (!SIZE_ONLY)                                     \
712         SAVEFREESV(RExC_rx_sv);                         \
713     Simple_vFAIL3(m, a1, a2);                           \
714 } STMT_END
715
716 /*
717  * Like Simple_vFAIL(), but accepts four arguments.
718  */
719 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
720     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
721             REPORT_LOCATION_ARGS(RExC_parse));                  \
722 } STMT_END
723
724 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
725     if (!SIZE_ONLY)                                     \
726         SAVEFREESV(RExC_rx_sv);                         \
727     Simple_vFAIL4(m, a1, a2, a3);                       \
728 } STMT_END
729
730 /* A specialized version of vFAIL2 that works with UTF8f */
731 #define vFAIL2utf8f(m, a1) STMT_START {             \
732     if (!SIZE_ONLY)                                 \
733         SAVEFREESV(RExC_rx_sv);                     \
734     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
735             REPORT_LOCATION_ARGS(RExC_parse));      \
736 } STMT_END
737
738 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
739     if (!SIZE_ONLY)                                     \
740         SAVEFREESV(RExC_rx_sv);                         \
741     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
742             REPORT_LOCATION_ARGS(RExC_parse));          \
743 } STMT_END
744
745 /* These have asserts in them because of [perl #122671] Many warnings in
746  * regcomp.c can occur twice.  If they get output in pass1 and later in that
747  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
748  * would get output again.  So they should be output in pass2, and these
749  * asserts make sure new warnings follow that paradigm. */
750
751 /* m is not necessarily a "literal string", in this macro */
752 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
753     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
754                                        "%s" REPORT_LOCATION,            \
755                                   m, REPORT_LOCATION_ARGS(loc));        \
756 } STMT_END
757
758 #define ckWARNreg(loc,m) STMT_START {                                   \
759     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
760                                           m REPORT_LOCATION,            \
761                                           REPORT_LOCATION_ARGS(loc));   \
762 } STMT_END
763
764 #define vWARN(loc, m) STMT_START {                                      \
765     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
766                                        m REPORT_LOCATION,               \
767                                        REPORT_LOCATION_ARGS(loc));      \
768 } STMT_END
769
770 #define vWARN_dep(loc, m) STMT_START {                                  \
771     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
772                                        m REPORT_LOCATION,               \
773                                        REPORT_LOCATION_ARGS(loc));      \
774 } STMT_END
775
776 #define ckWARNdep(loc,m) STMT_START {                                   \
777     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
778                                             m REPORT_LOCATION,          \
779                                             REPORT_LOCATION_ARGS(loc)); \
780 } STMT_END
781
782 #define ckWARNregdep(loc,m) STMT_START {                                    \
783     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
784                                                       WARN_REGEXP),         \
785                                              m REPORT_LOCATION,             \
786                                              REPORT_LOCATION_ARGS(loc));    \
787 } STMT_END
788
789 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
790     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
791                                             m REPORT_LOCATION,              \
792                                             a1, REPORT_LOCATION_ARGS(loc)); \
793 } STMT_END
794
795 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
796     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
797                                           m REPORT_LOCATION,                \
798                                           a1, REPORT_LOCATION_ARGS(loc));   \
799 } STMT_END
800
801 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
802     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
803                                        m REPORT_LOCATION,                   \
804                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
805 } STMT_END
806
807 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
808     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
809                                           m REPORT_LOCATION,                \
810                                           a1, a2,                           \
811                                           REPORT_LOCATION_ARGS(loc));       \
812 } STMT_END
813
814 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
815     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
816                                        m REPORT_LOCATION,               \
817                                        a1, a2, a3,                      \
818                                        REPORT_LOCATION_ARGS(loc));      \
819 } STMT_END
820
821 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
822     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
823                                           m REPORT_LOCATION,            \
824                                           a1, a2, a3,                   \
825                                           REPORT_LOCATION_ARGS(loc));   \
826 } STMT_END
827
828 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
829     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
830                                        m REPORT_LOCATION,               \
831                                        a1, a2, a3, a4,                  \
832                                        REPORT_LOCATION_ARGS(loc));      \
833 } STMT_END
834
835 /* Macros for recording node offsets.   20001227 mjd@plover.com
836  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
837  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
838  * Element 0 holds the number n.
839  * Position is 1 indexed.
840  */
841 #ifndef RE_TRACK_PATTERN_OFFSETS
842 #define Set_Node_Offset_To_R(node,byte)
843 #define Set_Node_Offset(node,byte)
844 #define Set_Cur_Node_Offset
845 #define Set_Node_Length_To_R(node,len)
846 #define Set_Node_Length(node,len)
847 #define Set_Node_Cur_Length(node,start)
848 #define Node_Offset(n)
849 #define Node_Length(n)
850 #define Set_Node_Offset_Length(node,offset,len)
851 #define ProgLen(ri) ri->u.proglen
852 #define SetProgLen(ri,x) ri->u.proglen = x
853 #else
854 #define ProgLen(ri) ri->u.offsets[0]
855 #define SetProgLen(ri,x) ri->u.offsets[0] = x
856 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
857     if (! SIZE_ONLY) {                                                  \
858         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
859                     __LINE__, (int)(node), (int)(byte)));               \
860         if((node) < 0) {                                                \
861             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
862                                          (int)(node));                  \
863         } else {                                                        \
864             RExC_offsets[2*(node)-1] = (byte);                          \
865         }                                                               \
866     }                                                                   \
867 } STMT_END
868
869 #define Set_Node_Offset(node,byte) \
870     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
871 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
872
873 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
874     if (! SIZE_ONLY) {                                                  \
875         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
876                 __LINE__, (int)(node), (int)(len)));                    \
877         if((node) < 0) {                                                \
878             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
879                                          (int)(node));                  \
880         } else {                                                        \
881             RExC_offsets[2*(node)] = (len);                             \
882         }                                                               \
883     }                                                                   \
884 } STMT_END
885
886 #define Set_Node_Length(node,len) \
887     Set_Node_Length_To_R((node)-RExC_emit_start, len)
888 #define Set_Node_Cur_Length(node, start)                \
889     Set_Node_Length(node, RExC_parse - start)
890
891 /* Get offsets and lengths */
892 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
893 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
894
895 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
896     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
897     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
898 } STMT_END
899 #endif
900
901 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
902 #define EXPERIMENTAL_INPLACESCAN
903 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
904
905 #ifdef DEBUGGING
906 int
907 Perl_re_printf(pTHX_ const char *fmt, ...)
908 {
909     va_list ap;
910     int result;
911     PerlIO *f= Perl_debug_log;
912     PERL_ARGS_ASSERT_RE_PRINTF;
913     va_start(ap, fmt);
914     result = PerlIO_vprintf(f, fmt, ap);
915     va_end(ap);
916     return result;
917 }
918
919 int
920 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
921 {
922     va_list ap;
923     int result;
924     PerlIO *f= Perl_debug_log;
925     PERL_ARGS_ASSERT_RE_INDENTF;
926     va_start(ap, depth);
927     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
928     result = PerlIO_vprintf(f, fmt, ap);
929     va_end(ap);
930     return result;
931 }
932 #endif /* DEBUGGING */
933
934 #define DEBUG_RExC_seen()                                                   \
935         DEBUG_OPTIMISE_MORE_r({                                             \
936             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
937                                                                             \
938             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
939                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
940                                                                             \
941             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
942                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
943                                                                             \
944             if (RExC_seen & REG_GPOS_SEEN)                                  \
945                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
946                                                                             \
947             if (RExC_seen & REG_RECURSE_SEEN)                               \
948                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
949                                                                             \
950             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
951                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
952                                                                             \
953             if (RExC_seen & REG_VERBARG_SEEN)                               \
954                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
955                                                                             \
956             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
957                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
958                                                                             \
959             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
960                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
961                                                                             \
962             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
963                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
964                                                                             \
965             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
966                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
967                                                                             \
968             Perl_re_printf( aTHX_ "\n");                                                \
969         });
970
971 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
972   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
973
974 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
975     if ( ( flags ) ) {                                                      \
976         Perl_re_printf( aTHX_  "%s", open_str);                                         \
977         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
978         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
979         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
980         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
981         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
982         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
983         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
984         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
985         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
986         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
987         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
988         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
989         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
990         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
991         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
992         Perl_re_printf( aTHX_  "%s", close_str);                                        \
993     }
994
995
996 #define DEBUG_STUDYDATA(str,data,depth)                              \
997 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
998     Perl_re_indentf( aTHX_  "" str "Pos:%" IVdf "/%" IVdf            \
999         " Flags: 0x%" UVXf,                                          \
1000         depth,                                                       \
1001         (IV)((data)->pos_min),                                       \
1002         (IV)((data)->pos_delta),                                     \
1003         (UV)((data)->flags)                                          \
1004     );                                                               \
1005     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
1006     Perl_re_printf( aTHX_                                            \
1007         " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",                    \
1008         (IV)((data)->whilem_c),                                      \
1009         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
1010         is_inf ? "INF " : ""                                         \
1011     );                                                               \
1012     if ((data)->last_found)                                          \
1013         Perl_re_printf( aTHX_                                        \
1014             "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf                   \
1015             " %sFixed:'%s' @ %" IVdf                                 \
1016             " %sFloat: '%s' @ %" IVdf "/%" IVdf,                     \
1017             SvPVX_const((data)->last_found),                         \
1018             (IV)((data)->last_end),                                  \
1019             (IV)((data)->last_start_min),                            \
1020             (IV)((data)->last_start_max),                            \
1021             ((data)->longest &&                                      \
1022              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
1023             SvPVX_const((data)->longest_fixed),                      \
1024             (IV)((data)->offset_fixed),                              \
1025             ((data)->longest &&                                      \
1026              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
1027             SvPVX_const((data)->longest_float),                      \
1028             (IV)((data)->offset_float_min),                          \
1029             (IV)((data)->offset_float_max)                           \
1030         );                                                           \
1031     Perl_re_printf( aTHX_ "\n");                                                 \
1032 });
1033
1034
1035 /* =========================================================
1036  * BEGIN edit_distance stuff.
1037  *
1038  * This calculates how many single character changes of any type are needed to
1039  * transform a string into another one.  It is taken from version 3.1 of
1040  *
1041  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1042  */
1043
1044 /* Our unsorted dictionary linked list.   */
1045 /* Note we use UVs, not chars. */
1046
1047 struct dictionary{
1048   UV key;
1049   UV value;
1050   struct dictionary* next;
1051 };
1052 typedef struct dictionary item;
1053
1054
1055 PERL_STATIC_INLINE item*
1056 push(UV key,item* curr)
1057 {
1058     item* head;
1059     Newxz(head, 1, item);
1060     head->key = key;
1061     head->value = 0;
1062     head->next = curr;
1063     return head;
1064 }
1065
1066
1067 PERL_STATIC_INLINE item*
1068 find(item* head, UV key)
1069 {
1070     item* iterator = head;
1071     while (iterator){
1072         if (iterator->key == key){
1073             return iterator;
1074         }
1075         iterator = iterator->next;
1076     }
1077
1078     return NULL;
1079 }
1080
1081 PERL_STATIC_INLINE item*
1082 uniquePush(item* head,UV key)
1083 {
1084     item* iterator = head;
1085
1086     while (iterator){
1087         if (iterator->key == key) {
1088             return head;
1089         }
1090         iterator = iterator->next;
1091     }
1092
1093     return push(key,head);
1094 }
1095
1096 PERL_STATIC_INLINE void
1097 dict_free(item* head)
1098 {
1099     item* iterator = head;
1100
1101     while (iterator) {
1102         item* temp = iterator;
1103         iterator = iterator->next;
1104         Safefree(temp);
1105     }
1106
1107     head = NULL;
1108 }
1109
1110 /* End of Dictionary Stuff */
1111
1112 /* All calculations/work are done here */
1113 STATIC int
1114 S_edit_distance(const UV* src,
1115                 const UV* tgt,
1116                 const STRLEN x,             /* length of src[] */
1117                 const STRLEN y,             /* length of tgt[] */
1118                 const SSize_t maxDistance
1119 )
1120 {
1121     item *head = NULL;
1122     UV swapCount,swapScore,targetCharCount,i,j;
1123     UV *scores;
1124     UV score_ceil = x + y;
1125
1126     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1127
1128     /* intialize matrix start values */
1129     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1130     scores[0] = score_ceil;
1131     scores[1 * (y + 2) + 0] = score_ceil;
1132     scores[0 * (y + 2) + 1] = score_ceil;
1133     scores[1 * (y + 2) + 1] = 0;
1134     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1135
1136     /* work loops    */
1137     /* i = src index */
1138     /* j = tgt index */
1139     for (i=1;i<=x;i++) {
1140         if (i < x)
1141             head = uniquePush(head,src[i]);
1142         scores[(i+1) * (y + 2) + 1] = i;
1143         scores[(i+1) * (y + 2) + 0] = score_ceil;
1144         swapCount = 0;
1145
1146         for (j=1;j<=y;j++) {
1147             if (i == 1) {
1148                 if(j < y)
1149                 head = uniquePush(head,tgt[j]);
1150                 scores[1 * (y + 2) + (j + 1)] = j;
1151                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1152             }
1153
1154             targetCharCount = find(head,tgt[j-1])->value;
1155             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1156
1157             if (src[i-1] != tgt[j-1]){
1158                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(swapScore,(MIN(scores[i * (y + 2) + j], MIN(scores[(i+1) * (y + 2) + j], scores[i * (y + 2) + (j + 1)])) + 1));
1159             }
1160             else {
1161                 swapCount = j;
1162                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1163             }
1164         }
1165
1166         find(head,src[i-1])->value = i;
1167     }
1168
1169     {
1170         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1171         dict_free(head);
1172         Safefree(scores);
1173         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1174     }
1175 }
1176
1177 /* END of edit_distance() stuff
1178  * ========================================================= */
1179
1180 /* is c a control character for which we have a mnemonic? */
1181 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1182
1183 STATIC const char *
1184 S_cntrl_to_mnemonic(const U8 c)
1185 {
1186     /* Returns the mnemonic string that represents character 'c', if one
1187      * exists; NULL otherwise.  The only ones that exist for the purposes of
1188      * this routine are a few control characters */
1189
1190     switch (c) {
1191         case '\a':       return "\\a";
1192         case '\b':       return "\\b";
1193         case ESC_NATIVE: return "\\e";
1194         case '\f':       return "\\f";
1195         case '\n':       return "\\n";
1196         case '\r':       return "\\r";
1197         case '\t':       return "\\t";
1198     }
1199
1200     return NULL;
1201 }
1202
1203 /* Mark that we cannot extend a found fixed substring at this point.
1204    Update the longest found anchored substring and the longest found
1205    floating substrings if needed. */
1206
1207 STATIC void
1208 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1209                     SSize_t *minlenp, int is_inf)
1210 {
1211     const STRLEN l = CHR_SVLEN(data->last_found);
1212     const STRLEN old_l = CHR_SVLEN(*data->longest);
1213     GET_RE_DEBUG_FLAGS_DECL;
1214
1215     PERL_ARGS_ASSERT_SCAN_COMMIT;
1216
1217     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1218         SvSetMagicSV(*data->longest, data->last_found);
1219         if (*data->longest == data->longest_fixed) {
1220             data->offset_fixed = l ? data->last_start_min : data->pos_min;
1221             if (data->flags & SF_BEFORE_EOL)
1222                 data->flags
1223                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
1224             else
1225                 data->flags &= ~SF_FIX_BEFORE_EOL;
1226             data->minlen_fixed=minlenp;
1227             data->lookbehind_fixed=0;
1228         }
1229         else { /* *data->longest == data->longest_float */
1230             data->offset_float_min = l ? data->last_start_min : data->pos_min;
1231             data->offset_float_max = (l
1232                           ? data->last_start_max
1233                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1234                                          ? SSize_t_MAX
1235                                          : data->pos_min + data->pos_delta));
1236             if (is_inf
1237                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
1238                 data->offset_float_max = SSize_t_MAX;
1239             if (data->flags & SF_BEFORE_EOL)
1240                 data->flags
1241                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
1242             else
1243                 data->flags &= ~SF_FL_BEFORE_EOL;
1244             data->minlen_float=minlenp;
1245             data->lookbehind_float=0;
1246         }
1247     }
1248     SvCUR_set(data->last_found, 0);
1249     {
1250         SV * const sv = data->last_found;
1251         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1252             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1253             if (mg)
1254                 mg->mg_len = 0;
1255         }
1256     }
1257     data->last_end = -1;
1258     data->flags &= ~SF_BEFORE_EOL;
1259     DEBUG_STUDYDATA("commit: ",data,0);
1260 }
1261
1262 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1263  * list that describes which code points it matches */
1264
1265 STATIC void
1266 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1267 {
1268     /* Set the SSC 'ssc' to match an empty string or any code point */
1269
1270     PERL_ARGS_ASSERT_SSC_ANYTHING;
1271
1272     assert(is_ANYOF_SYNTHETIC(ssc));
1273
1274     /* mortalize so won't leak */
1275     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1276     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1277 }
1278
1279 STATIC int
1280 S_ssc_is_anything(const regnode_ssc *ssc)
1281 {
1282     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1283      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1284      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1285      * in any way, so there's no point in using it */
1286
1287     UV start, end;
1288     bool ret;
1289
1290     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1291
1292     assert(is_ANYOF_SYNTHETIC(ssc));
1293
1294     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1295         return FALSE;
1296     }
1297
1298     /* See if the list consists solely of the range 0 - Infinity */
1299     invlist_iterinit(ssc->invlist);
1300     ret = invlist_iternext(ssc->invlist, &start, &end)
1301           && start == 0
1302           && end == UV_MAX;
1303
1304     invlist_iterfinish(ssc->invlist);
1305
1306     if (ret) {
1307         return TRUE;
1308     }
1309
1310     /* If e.g., both \w and \W are set, matches everything */
1311     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1312         int i;
1313         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1314             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1315                 return TRUE;
1316             }
1317         }
1318     }
1319
1320     return FALSE;
1321 }
1322
1323 STATIC void
1324 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1325 {
1326     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1327      * string, any code point, or any posix class under locale */
1328
1329     PERL_ARGS_ASSERT_SSC_INIT;
1330
1331     Zero(ssc, 1, regnode_ssc);
1332     set_ANYOF_SYNTHETIC(ssc);
1333     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1334     ssc_anything(ssc);
1335
1336     /* If any portion of the regex is to operate under locale rules that aren't
1337      * fully known at compile time, initialization includes it.  The reason
1338      * this isn't done for all regexes is that the optimizer was written under
1339      * the assumption that locale was all-or-nothing.  Given the complexity and
1340      * lack of documentation in the optimizer, and that there are inadequate
1341      * test cases for locale, many parts of it may not work properly, it is
1342      * safest to avoid locale unless necessary. */
1343     if (RExC_contains_locale) {
1344         ANYOF_POSIXL_SETALL(ssc);
1345     }
1346     else {
1347         ANYOF_POSIXL_ZERO(ssc);
1348     }
1349 }
1350
1351 STATIC int
1352 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1353                         const regnode_ssc *ssc)
1354 {
1355     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1356      * to the list of code points matched, and locale posix classes; hence does
1357      * not check its flags) */
1358
1359     UV start, end;
1360     bool ret;
1361
1362     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1363
1364     assert(is_ANYOF_SYNTHETIC(ssc));
1365
1366     invlist_iterinit(ssc->invlist);
1367     ret = invlist_iternext(ssc->invlist, &start, &end)
1368           && start == 0
1369           && end == UV_MAX;
1370
1371     invlist_iterfinish(ssc->invlist);
1372
1373     if (! ret) {
1374         return FALSE;
1375     }
1376
1377     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1378         return FALSE;
1379     }
1380
1381     return TRUE;
1382 }
1383
1384 STATIC SV*
1385 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1386                                const regnode_charclass* const node)
1387 {
1388     /* Returns a mortal inversion list defining which code points are matched
1389      * by 'node', which is of type ANYOF.  Handles complementing the result if
1390      * appropriate.  If some code points aren't knowable at this time, the
1391      * returned list must, and will, contain every code point that is a
1392      * possibility. */
1393
1394     SV* invlist = NULL;
1395     SV* only_utf8_locale_invlist = NULL;
1396     unsigned int i;
1397     const U32 n = ARG(node);
1398     bool new_node_has_latin1 = FALSE;
1399
1400     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1401
1402     /* Look at the data structure created by S_set_ANYOF_arg() */
1403     if (n != ANYOF_ONLY_HAS_BITMAP) {
1404         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1405         AV * const av = MUTABLE_AV(SvRV(rv));
1406         SV **const ary = AvARRAY(av);
1407         assert(RExC_rxi->data->what[n] == 's');
1408
1409         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1410             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1411         }
1412         else if (ary[0] && ary[0] != &PL_sv_undef) {
1413
1414             /* Here, no compile-time swash, and there are things that won't be
1415              * known until runtime -- we have to assume it could be anything */
1416             invlist = sv_2mortal(_new_invlist(1));
1417             return _add_range_to_invlist(invlist, 0, UV_MAX);
1418         }
1419         else if (ary[3] && ary[3] != &PL_sv_undef) {
1420
1421             /* Here no compile-time swash, and no run-time only data.  Use the
1422              * node's inversion list */
1423             invlist = sv_2mortal(invlist_clone(ary[3]));
1424         }
1425
1426         /* Get the code points valid only under UTF-8 locales */
1427         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1428             && ary[2] && ary[2] != &PL_sv_undef)
1429         {
1430             only_utf8_locale_invlist = ary[2];
1431         }
1432     }
1433
1434     if (! invlist) {
1435         invlist = sv_2mortal(_new_invlist(0));
1436     }
1437
1438     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1439      * code points, and an inversion list for the others, but if there are code
1440      * points that should match only conditionally on the target string being
1441      * UTF-8, those are placed in the inversion list, and not the bitmap.
1442      * Since there are circumstances under which they could match, they are
1443      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1444      * to exclude them here, so that when we invert below, the end result
1445      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1446      * have to do this here before we add the unconditionally matched code
1447      * points */
1448     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1449         _invlist_intersection_complement_2nd(invlist,
1450                                              PL_UpperLatin1,
1451                                              &invlist);
1452     }
1453
1454     /* Add in the points from the bit map */
1455     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1456         if (ANYOF_BITMAP_TEST(node, i)) {
1457             unsigned int start = i++;
1458
1459             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1460                 /* empty */
1461             }
1462             invlist = _add_range_to_invlist(invlist, start, i-1);
1463             new_node_has_latin1 = TRUE;
1464         }
1465     }
1466
1467     /* If this can match all upper Latin1 code points, have to add them
1468      * as well.  But don't add them if inverting, as when that gets done below,
1469      * it would exclude all these characters, including the ones it shouldn't
1470      * that were added just above */
1471     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1472         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1473     {
1474         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1475     }
1476
1477     /* Similarly for these */
1478     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1479         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1480     }
1481
1482     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1483         _invlist_invert(invlist);
1484     }
1485     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1486
1487         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1488          * locale.  We can skip this if there are no 0-255 at all. */
1489         _invlist_union(invlist, PL_Latin1, &invlist);
1490     }
1491
1492     /* Similarly add the UTF-8 locale possible matches.  These have to be
1493      * deferred until after the non-UTF-8 locale ones are taken care of just
1494      * above, or it leads to wrong results under ANYOF_INVERT */
1495     if (only_utf8_locale_invlist) {
1496         _invlist_union_maybe_complement_2nd(invlist,
1497                                             only_utf8_locale_invlist,
1498                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1499                                             &invlist);
1500     }
1501
1502     return invlist;
1503 }
1504
1505 /* These two functions currently do the exact same thing */
1506 #define ssc_init_zero           ssc_init
1507
1508 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1509 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1510
1511 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1512  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1513  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1514
1515 STATIC void
1516 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1517                 const regnode_charclass *and_with)
1518 {
1519     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1520      * another SSC or a regular ANYOF class.  Can create false positives. */
1521
1522     SV* anded_cp_list;
1523     U8  anded_flags;
1524
1525     PERL_ARGS_ASSERT_SSC_AND;
1526
1527     assert(is_ANYOF_SYNTHETIC(ssc));
1528
1529     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1530      * the code point inversion list and just the relevant flags */
1531     if (is_ANYOF_SYNTHETIC(and_with)) {
1532         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1533         anded_flags = ANYOF_FLAGS(and_with);
1534
1535         /* XXX This is a kludge around what appears to be deficiencies in the
1536          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1537          * there are paths through the optimizer where it doesn't get weeded
1538          * out when it should.  And if we don't make some extra provision for
1539          * it like the code just below, it doesn't get added when it should.
1540          * This solution is to add it only when AND'ing, which is here, and
1541          * only when what is being AND'ed is the pristine, original node
1542          * matching anything.  Thus it is like adding it to ssc_anything() but
1543          * only when the result is to be AND'ed.  Probably the same solution
1544          * could be adopted for the same problem we have with /l matching,
1545          * which is solved differently in S_ssc_init(), and that would lead to
1546          * fewer false positives than that solution has.  But if this solution
1547          * creates bugs, the consequences are only that a warning isn't raised
1548          * that should be; while the consequences for having /l bugs is
1549          * incorrect matches */
1550         if (ssc_is_anything((regnode_ssc *)and_with)) {
1551             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1552         }
1553     }
1554     else {
1555         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1556         if (OP(and_with) == ANYOFD) {
1557             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1558         }
1559         else {
1560             anded_flags = ANYOF_FLAGS(and_with)
1561             &( ANYOF_COMMON_FLAGS
1562               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1563               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1564             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1565                 anded_flags &=
1566                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1567             }
1568         }
1569     }
1570
1571     ANYOF_FLAGS(ssc) &= anded_flags;
1572
1573     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1574      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1575      * 'and_with' may be inverted.  When not inverted, we have the situation of
1576      * computing:
1577      *  (C1 | P1) & (C2 | P2)
1578      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1579      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1580      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1581      *                    <=  ((C1 & C2) | P1 | P2)
1582      * Alternatively, the last few steps could be:
1583      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1584      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1585      *                    <=  (C1 | C2 | (P1 & P2))
1586      * We favor the second approach if either P1 or P2 is non-empty.  This is
1587      * because these components are a barrier to doing optimizations, as what
1588      * they match cannot be known until the moment of matching as they are
1589      * dependent on the current locale, 'AND"ing them likely will reduce or
1590      * eliminate them.
1591      * But we can do better if we know that C1,P1 are in their initial state (a
1592      * frequent occurrence), each matching everything:
1593      *  (<everything>) & (C2 | P2) =  C2 | P2
1594      * Similarly, if C2,P2 are in their initial state (again a frequent
1595      * occurrence), the result is a no-op
1596      *  (C1 | P1) & (<everything>) =  C1 | P1
1597      *
1598      * Inverted, we have
1599      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1600      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1601      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1602      * */
1603
1604     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1605         && ! is_ANYOF_SYNTHETIC(and_with))
1606     {
1607         unsigned int i;
1608
1609         ssc_intersection(ssc,
1610                          anded_cp_list,
1611                          FALSE /* Has already been inverted */
1612                          );
1613
1614         /* If either P1 or P2 is empty, the intersection will be also; can skip
1615          * the loop */
1616         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1617             ANYOF_POSIXL_ZERO(ssc);
1618         }
1619         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1620
1621             /* Note that the Posix class component P from 'and_with' actually
1622              * looks like:
1623              *      P = Pa | Pb | ... | Pn
1624              * where each component is one posix class, such as in [\w\s].
1625              * Thus
1626              *      ~P = ~(Pa | Pb | ... | Pn)
1627              *         = ~Pa & ~Pb & ... & ~Pn
1628              *        <= ~Pa | ~Pb | ... | ~Pn
1629              * The last is something we can easily calculate, but unfortunately
1630              * is likely to have many false positives.  We could do better
1631              * in some (but certainly not all) instances if two classes in
1632              * P have known relationships.  For example
1633              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1634              * So
1635              *      :lower: & :print: = :lower:
1636              * And similarly for classes that must be disjoint.  For example,
1637              * since \s and \w can have no elements in common based on rules in
1638              * the POSIX standard,
1639              *      \w & ^\S = nothing
1640              * Unfortunately, some vendor locales do not meet the Posix
1641              * standard, in particular almost everything by Microsoft.
1642              * The loop below just changes e.g., \w into \W and vice versa */
1643
1644             regnode_charclass_posixl temp;
1645             int add = 1;    /* To calculate the index of the complement */
1646
1647             ANYOF_POSIXL_ZERO(&temp);
1648             for (i = 0; i < ANYOF_MAX; i++) {
1649                 assert(i % 2 != 0
1650                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1651                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1652
1653                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1654                     ANYOF_POSIXL_SET(&temp, i + add);
1655                 }
1656                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1657             }
1658             ANYOF_POSIXL_AND(&temp, ssc);
1659
1660         } /* else ssc already has no posixes */
1661     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1662          in its initial state */
1663     else if (! is_ANYOF_SYNTHETIC(and_with)
1664              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1665     {
1666         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1667          * copy it over 'ssc' */
1668         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1669             if (is_ANYOF_SYNTHETIC(and_with)) {
1670                 StructCopy(and_with, ssc, regnode_ssc);
1671             }
1672             else {
1673                 ssc->invlist = anded_cp_list;
1674                 ANYOF_POSIXL_ZERO(ssc);
1675                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1676                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1677                 }
1678             }
1679         }
1680         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1681                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1682         {
1683             /* One or the other of P1, P2 is non-empty. */
1684             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1685                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1686             }
1687             ssc_union(ssc, anded_cp_list, FALSE);
1688         }
1689         else { /* P1 = P2 = empty */
1690             ssc_intersection(ssc, anded_cp_list, FALSE);
1691         }
1692     }
1693 }
1694
1695 STATIC void
1696 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1697                const regnode_charclass *or_with)
1698 {
1699     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1700      * another SSC or a regular ANYOF class.  Can create false positives if
1701      * 'or_with' is to be inverted. */
1702
1703     SV* ored_cp_list;
1704     U8 ored_flags;
1705
1706     PERL_ARGS_ASSERT_SSC_OR;
1707
1708     assert(is_ANYOF_SYNTHETIC(ssc));
1709
1710     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1711      * the code point inversion list and just the relevant flags */
1712     if (is_ANYOF_SYNTHETIC(or_with)) {
1713         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1714         ored_flags = ANYOF_FLAGS(or_with);
1715     }
1716     else {
1717         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1718         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1719         if (OP(or_with) != ANYOFD) {
1720             ored_flags
1721             |= ANYOF_FLAGS(or_with)
1722              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1723                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1724             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1725                 ored_flags |=
1726                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1727             }
1728         }
1729     }
1730
1731     ANYOF_FLAGS(ssc) |= ored_flags;
1732
1733     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1734      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1735      * 'or_with' may be inverted.  When not inverted, we have the simple
1736      * situation of computing:
1737      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1738      * If P1|P2 yields a situation with both a class and its complement are
1739      * set, like having both \w and \W, this matches all code points, and we
1740      * can delete these from the P component of the ssc going forward.  XXX We
1741      * might be able to delete all the P components, but I (khw) am not certain
1742      * about this, and it is better to be safe.
1743      *
1744      * Inverted, we have
1745      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1746      *                         <=  (C1 | P1) | ~C2
1747      *                         <=  (C1 | ~C2) | P1
1748      * (which results in actually simpler code than the non-inverted case)
1749      * */
1750
1751     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1752         && ! is_ANYOF_SYNTHETIC(or_with))
1753     {
1754         /* We ignore P2, leaving P1 going forward */
1755     }   /* else  Not inverted */
1756     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1757         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1758         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1759             unsigned int i;
1760             for (i = 0; i < ANYOF_MAX; i += 2) {
1761                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1762                 {
1763                     ssc_match_all_cp(ssc);
1764                     ANYOF_POSIXL_CLEAR(ssc, i);
1765                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1766                 }
1767             }
1768         }
1769     }
1770
1771     ssc_union(ssc,
1772               ored_cp_list,
1773               FALSE /* Already has been inverted */
1774               );
1775 }
1776
1777 PERL_STATIC_INLINE void
1778 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1779 {
1780     PERL_ARGS_ASSERT_SSC_UNION;
1781
1782     assert(is_ANYOF_SYNTHETIC(ssc));
1783
1784     _invlist_union_maybe_complement_2nd(ssc->invlist,
1785                                         invlist,
1786                                         invert2nd,
1787                                         &ssc->invlist);
1788 }
1789
1790 PERL_STATIC_INLINE void
1791 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1792                          SV* const invlist,
1793                          const bool invert2nd)
1794 {
1795     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1796
1797     assert(is_ANYOF_SYNTHETIC(ssc));
1798
1799     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1800                                                invlist,
1801                                                invert2nd,
1802                                                &ssc->invlist);
1803 }
1804
1805 PERL_STATIC_INLINE void
1806 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1807 {
1808     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1809
1810     assert(is_ANYOF_SYNTHETIC(ssc));
1811
1812     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1813 }
1814
1815 PERL_STATIC_INLINE void
1816 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1817 {
1818     /* AND just the single code point 'cp' into the SSC 'ssc' */
1819
1820     SV* cp_list = _new_invlist(2);
1821
1822     PERL_ARGS_ASSERT_SSC_CP_AND;
1823
1824     assert(is_ANYOF_SYNTHETIC(ssc));
1825
1826     cp_list = add_cp_to_invlist(cp_list, cp);
1827     ssc_intersection(ssc, cp_list,
1828                      FALSE /* Not inverted */
1829                      );
1830     SvREFCNT_dec_NN(cp_list);
1831 }
1832
1833 PERL_STATIC_INLINE void
1834 S_ssc_clear_locale(regnode_ssc *ssc)
1835 {
1836     /* Set the SSC 'ssc' to not match any locale things */
1837     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1838
1839     assert(is_ANYOF_SYNTHETIC(ssc));
1840
1841     ANYOF_POSIXL_ZERO(ssc);
1842     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1843 }
1844
1845 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1846
1847 STATIC bool
1848 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1849 {
1850     /* The synthetic start class is used to hopefully quickly winnow down
1851      * places where a pattern could start a match in the target string.  If it
1852      * doesn't really narrow things down that much, there isn't much point to
1853      * having the overhead of using it.  This function uses some very crude
1854      * heuristics to decide if to use the ssc or not.
1855      *
1856      * It returns TRUE if 'ssc' rules out more than half what it considers to
1857      * be the "likely" possible matches, but of course it doesn't know what the
1858      * actual things being matched are going to be; these are only guesses
1859      *
1860      * For /l matches, it assumes that the only likely matches are going to be
1861      *      in the 0-255 range, uniformly distributed, so half of that is 127
1862      * For /a and /d matches, it assumes that the likely matches will be just
1863      *      the ASCII range, so half of that is 63
1864      * For /u and there isn't anything matching above the Latin1 range, it
1865      *      assumes that that is the only range likely to be matched, and uses
1866      *      half that as the cut-off: 127.  If anything matches above Latin1,
1867      *      it assumes that all of Unicode could match (uniformly), except for
1868      *      non-Unicode code points and things in the General Category "Other"
1869      *      (unassigned, private use, surrogates, controls and formats).  This
1870      *      is a much large number. */
1871
1872     U32 count = 0;      /* Running total of number of code points matched by
1873                            'ssc' */
1874     UV start, end;      /* Start and end points of current range in inversion
1875                            list */
1876     const U32 max_code_points = (LOC)
1877                                 ?  256
1878                                 : ((   ! UNI_SEMANTICS
1879                                      || invlist_highest(ssc->invlist) < 256)
1880                                   ? 128
1881                                   : NON_OTHER_COUNT);
1882     const U32 max_match = max_code_points / 2;
1883
1884     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1885
1886     invlist_iterinit(ssc->invlist);
1887     while (invlist_iternext(ssc->invlist, &start, &end)) {
1888         if (start >= max_code_points) {
1889             break;
1890         }
1891         end = MIN(end, max_code_points - 1);
1892         count += end - start + 1;
1893         if (count >= max_match) {
1894             invlist_iterfinish(ssc->invlist);
1895             return FALSE;
1896         }
1897     }
1898
1899     return TRUE;
1900 }
1901
1902
1903 STATIC void
1904 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1905 {
1906     /* The inversion list in the SSC is marked mortal; now we need a more
1907      * permanent copy, which is stored the same way that is done in a regular
1908      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1909      * map */
1910
1911     SV* invlist = invlist_clone(ssc->invlist);
1912
1913     PERL_ARGS_ASSERT_SSC_FINALIZE;
1914
1915     assert(is_ANYOF_SYNTHETIC(ssc));
1916
1917     /* The code in this file assumes that all but these flags aren't relevant
1918      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1919      * by the time we reach here */
1920     assert(! (ANYOF_FLAGS(ssc)
1921         & ~( ANYOF_COMMON_FLAGS
1922             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1923             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
1924
1925     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1926
1927     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1928                                 NULL, NULL, NULL, FALSE);
1929
1930     /* Make sure is clone-safe */
1931     ssc->invlist = NULL;
1932
1933     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1934         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1935     }
1936
1937     if (RExC_contains_locale) {
1938         OP(ssc) = ANYOFL;
1939     }
1940
1941     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1942 }
1943
1944 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1945 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1946 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1947 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1948                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1949                                : 0 )
1950
1951
1952 #ifdef DEBUGGING
1953 /*
1954    dump_trie(trie,widecharmap,revcharmap)
1955    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1956    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1957
1958    These routines dump out a trie in a somewhat readable format.
1959    The _interim_ variants are used for debugging the interim
1960    tables that are used to generate the final compressed
1961    representation which is what dump_trie expects.
1962
1963    Part of the reason for their existence is to provide a form
1964    of documentation as to how the different representations function.
1965
1966 */
1967
1968 /*
1969   Dumps the final compressed table form of the trie to Perl_debug_log.
1970   Used for debugging make_trie().
1971 */
1972
1973 STATIC void
1974 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1975             AV *revcharmap, U32 depth)
1976 {
1977     U32 state;
1978     SV *sv=sv_newmortal();
1979     int colwidth= widecharmap ? 6 : 4;
1980     U16 word;
1981     GET_RE_DEBUG_FLAGS_DECL;
1982
1983     PERL_ARGS_ASSERT_DUMP_TRIE;
1984
1985     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
1986         depth+1, "Match","Base","Ofs" );
1987
1988     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1989         SV ** const tmp = av_fetch( revcharmap, state, 0);
1990         if ( tmp ) {
1991             Perl_re_printf( aTHX_  "%*s",
1992                 colwidth,
1993                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1994                             PL_colors[0], PL_colors[1],
1995                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1996                             PERL_PV_ESCAPE_FIRSTCHAR
1997                 )
1998             );
1999         }
2000     }
2001     Perl_re_printf( aTHX_  "\n");
2002     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2003
2004     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2005         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2006     Perl_re_printf( aTHX_  "\n");
2007
2008     for( state = 1 ; state < trie->statecount ; state++ ) {
2009         const U32 base = trie->states[ state ].trans.base;
2010
2011         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2012
2013         if ( trie->states[ state ].wordnum ) {
2014             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2015         } else {
2016             Perl_re_printf( aTHX_  "%6s", "" );
2017         }
2018
2019         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2020
2021         if ( base ) {
2022             U32 ofs = 0;
2023
2024             while( ( base + ofs  < trie->uniquecharcount ) ||
2025                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2026                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2027                                                                     != state))
2028                     ofs++;
2029
2030             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2031
2032             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2033                 if ( ( base + ofs >= trie->uniquecharcount )
2034                         && ( base + ofs - trie->uniquecharcount
2035                                                         < trie->lasttrans )
2036                         && trie->trans[ base + ofs
2037                                     - trie->uniquecharcount ].check == state )
2038                 {
2039                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2040                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2041                    );
2042                 } else {
2043                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2044                 }
2045             }
2046
2047             Perl_re_printf( aTHX_  "]");
2048
2049         }
2050         Perl_re_printf( aTHX_  "\n" );
2051     }
2052     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2053                                 depth);
2054     for (word=1; word <= trie->wordcount; word++) {
2055         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2056             (int)word, (int)(trie->wordinfo[word].prev),
2057             (int)(trie->wordinfo[word].len));
2058     }
2059     Perl_re_printf( aTHX_  "\n" );
2060 }
2061 /*
2062   Dumps a fully constructed but uncompressed trie in list form.
2063   List tries normally only are used for construction when the number of
2064   possible chars (trie->uniquecharcount) is very high.
2065   Used for debugging make_trie().
2066 */
2067 STATIC void
2068 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2069                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2070                          U32 depth)
2071 {
2072     U32 state;
2073     SV *sv=sv_newmortal();
2074     int colwidth= widecharmap ? 6 : 4;
2075     GET_RE_DEBUG_FLAGS_DECL;
2076
2077     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2078
2079     /* print out the table precompression.  */
2080     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2081             depth+1 );
2082     Perl_re_indentf( aTHX_  "%s",
2083             depth+1, "------:-----+-----------------\n" );
2084
2085     for( state=1 ; state < next_alloc ; state ++ ) {
2086         U16 charid;
2087
2088         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2089             depth+1, (UV)state  );
2090         if ( ! trie->states[ state ].wordnum ) {
2091             Perl_re_printf( aTHX_  "%5s| ","");
2092         } else {
2093             Perl_re_printf( aTHX_  "W%4x| ",
2094                 trie->states[ state ].wordnum
2095             );
2096         }
2097         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2098             SV ** const tmp = av_fetch( revcharmap,
2099                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2100             if ( tmp ) {
2101                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2102                     colwidth,
2103                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2104                               colwidth,
2105                               PL_colors[0], PL_colors[1],
2106                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2107                               | PERL_PV_ESCAPE_FIRSTCHAR
2108                     ) ,
2109                     TRIE_LIST_ITEM(state,charid).forid,
2110                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2111                 );
2112                 if (!(charid % 10))
2113                     Perl_re_printf( aTHX_  "\n%*s| ",
2114                         (int)((depth * 2) + 14), "");
2115             }
2116         }
2117         Perl_re_printf( aTHX_  "\n");
2118     }
2119 }
2120
2121 /*
2122   Dumps a fully constructed but uncompressed trie in table form.
2123   This is the normal DFA style state transition table, with a few
2124   twists to facilitate compression later.
2125   Used for debugging make_trie().
2126 */
2127 STATIC void
2128 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2129                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2130                           U32 depth)
2131 {
2132     U32 state;
2133     U16 charid;
2134     SV *sv=sv_newmortal();
2135     int colwidth= widecharmap ? 6 : 4;
2136     GET_RE_DEBUG_FLAGS_DECL;
2137
2138     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2139
2140     /*
2141        print out the table precompression so that we can do a visual check
2142        that they are identical.
2143      */
2144
2145     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2146
2147     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2148         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2149         if ( tmp ) {
2150             Perl_re_printf( aTHX_  "%*s",
2151                 colwidth,
2152                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2153                             PL_colors[0], PL_colors[1],
2154                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2155                             PERL_PV_ESCAPE_FIRSTCHAR
2156                 )
2157             );
2158         }
2159     }
2160
2161     Perl_re_printf( aTHX_ "\n");
2162     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2163
2164     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2165         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2166     }
2167
2168     Perl_re_printf( aTHX_  "\n" );
2169
2170     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2171
2172         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2173             depth+1,
2174             (UV)TRIE_NODENUM( state ) );
2175
2176         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2177             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2178             if (v)
2179                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2180             else
2181                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2182         }
2183         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2184             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2185                                             (UV)trie->trans[ state ].check );
2186         } else {
2187             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2188                                             (UV)trie->trans[ state ].check,
2189             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2190         }
2191     }
2192 }
2193
2194 #endif
2195
2196
2197 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2198   startbranch: the first branch in the whole branch sequence
2199   first      : start branch of sequence of branch-exact nodes.
2200                May be the same as startbranch
2201   last       : Thing following the last branch.
2202                May be the same as tail.
2203   tail       : item following the branch sequence
2204   count      : words in the sequence
2205   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2206   depth      : indent depth
2207
2208 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2209
2210 A trie is an N'ary tree where the branches are determined by digital
2211 decomposition of the key. IE, at the root node you look up the 1st character and
2212 follow that branch repeat until you find the end of the branches. Nodes can be
2213 marked as "accepting" meaning they represent a complete word. Eg:
2214
2215   /he|she|his|hers/
2216
2217 would convert into the following structure. Numbers represent states, letters
2218 following numbers represent valid transitions on the letter from that state, if
2219 the number is in square brackets it represents an accepting state, otherwise it
2220 will be in parenthesis.
2221
2222       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2223       |    |
2224       |   (2)
2225       |    |
2226      (1)   +-i->(6)-+-s->[7]
2227       |
2228       +-s->(3)-+-h->(4)-+-e->[5]
2229
2230       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2231
2232 This shows that when matching against the string 'hers' we will begin at state 1
2233 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2234 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2235 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2236 single traverse. We store a mapping from accepting to state to which word was
2237 matched, and then when we have multiple possibilities we try to complete the
2238 rest of the regex in the order in which they occurred in the alternation.
2239
2240 The only prior NFA like behaviour that would be changed by the TRIE support is
2241 the silent ignoring of duplicate alternations which are of the form:
2242
2243  / (DUPE|DUPE) X? (?{ ... }) Y /x
2244
2245 Thus EVAL blocks following a trie may be called a different number of times with
2246 and without the optimisation. With the optimisations dupes will be silently
2247 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2248 the following demonstrates:
2249
2250  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2251
2252 which prints out 'word' three times, but
2253
2254  'words'=~/(word|word|word)(?{ print $1 })S/
2255
2256 which doesnt print it out at all. This is due to other optimisations kicking in.
2257
2258 Example of what happens on a structural level:
2259
2260 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2261
2262    1: CURLYM[1] {1,32767}(18)
2263    5:   BRANCH(8)
2264    6:     EXACT <ac>(16)
2265    8:   BRANCH(11)
2266    9:     EXACT <ad>(16)
2267   11:   BRANCH(14)
2268   12:     EXACT <ab>(16)
2269   16:   SUCCEED(0)
2270   17:   NOTHING(18)
2271   18: END(0)
2272
2273 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2274 and should turn into:
2275
2276    1: CURLYM[1] {1,32767}(18)
2277    5:   TRIE(16)
2278         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2279           <ac>
2280           <ad>
2281           <ab>
2282   16:   SUCCEED(0)
2283   17:   NOTHING(18)
2284   18: END(0)
2285
2286 Cases where tail != last would be like /(?foo|bar)baz/:
2287
2288    1: BRANCH(4)
2289    2:   EXACT <foo>(8)
2290    4: BRANCH(7)
2291    5:   EXACT <bar>(8)
2292    7: TAIL(8)
2293    8: EXACT <baz>(10)
2294   10: END(0)
2295
2296 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2297 and would end up looking like:
2298
2299     1: TRIE(8)
2300       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2301         <foo>
2302         <bar>
2303    7: TAIL(8)
2304    8: EXACT <baz>(10)
2305   10: END(0)
2306
2307     d = uvchr_to_utf8_flags(d, uv, 0);
2308
2309 is the recommended Unicode-aware way of saying
2310
2311     *(d++) = uv;
2312 */
2313
2314 #define TRIE_STORE_REVCHAR(val)                                            \
2315     STMT_START {                                                           \
2316         if (UTF) {                                                         \
2317             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2318             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2319             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2320             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2321             SvPOK_on(zlopp);                                               \
2322             SvUTF8_on(zlopp);                                              \
2323             av_push(revcharmap, zlopp);                                    \
2324         } else {                                                           \
2325             char ooooff = (char)val;                                           \
2326             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2327         }                                                                  \
2328         } STMT_END
2329
2330 /* This gets the next character from the input, folding it if not already
2331  * folded. */
2332 #define TRIE_READ_CHAR STMT_START {                                           \
2333     wordlen++;                                                                \
2334     if ( UTF ) {                                                              \
2335         /* if it is UTF then it is either already folded, or does not need    \
2336          * folding */                                                         \
2337         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2338     }                                                                         \
2339     else if (folder == PL_fold_latin1) {                                      \
2340         /* This folder implies Unicode rules, which in the range expressible  \
2341          *  by not UTF is the lower case, with the two exceptions, one of     \
2342          *  which should have been taken care of before calling this */       \
2343         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2344         uvc = toLOWER_L1(*uc);                                                \
2345         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2346         len = 1;                                                              \
2347     } else {                                                                  \
2348         /* raw data, will be folded later if needed */                        \
2349         uvc = (U32)*uc;                                                       \
2350         len = 1;                                                              \
2351     }                                                                         \
2352 } STMT_END
2353
2354
2355
2356 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2357     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2358         U32 ging = TRIE_LIST_LEN( state ) * 2;                  \
2359         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2360         TRIE_LIST_LEN( state ) = ging;                          \
2361     }                                                           \
2362     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2363     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2364     TRIE_LIST_CUR( state )++;                                   \
2365 } STMT_END
2366
2367 #define TRIE_LIST_NEW(state) STMT_START {                       \
2368     Newxz( trie->states[ state ].trans.list,               \
2369         4, reg_trie_trans_le );                                 \
2370      TRIE_LIST_CUR( state ) = 1;                                \
2371      TRIE_LIST_LEN( state ) = 4;                                \
2372 } STMT_END
2373
2374 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2375     U16 dupe= trie->states[ state ].wordnum;                    \
2376     regnode * const noper_next = regnext( noper );              \
2377                                                                 \
2378     DEBUG_r({                                                   \
2379         /* store the word for dumping */                        \
2380         SV* tmp;                                                \
2381         if (OP(noper) != NOTHING)                               \
2382             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2383         else                                                    \
2384             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2385         av_push( trie_words, tmp );                             \
2386     });                                                         \
2387                                                                 \
2388     curword++;                                                  \
2389     trie->wordinfo[curword].prev   = 0;                         \
2390     trie->wordinfo[curword].len    = wordlen;                   \
2391     trie->wordinfo[curword].accept = state;                     \
2392                                                                 \
2393     if ( noper_next < tail ) {                                  \
2394         if (!trie->jump)                                        \
2395             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2396                                                  sizeof(U16) ); \
2397         trie->jump[curword] = (U16)(noper_next - convert);      \
2398         if (!jumper)                                            \
2399             jumper = noper_next;                                \
2400         if (!nextbranch)                                        \
2401             nextbranch= regnext(cur);                           \
2402     }                                                           \
2403                                                                 \
2404     if ( dupe ) {                                               \
2405         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2406         /* chain, so that when the bits of chain are later    */\
2407         /* linked together, the dups appear in the chain      */\
2408         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2409         trie->wordinfo[dupe].prev = curword;                    \
2410     } else {                                                    \
2411         /* we haven't inserted this word yet.                */ \
2412         trie->states[ state ].wordnum = curword;                \
2413     }                                                           \
2414 } STMT_END
2415
2416
2417 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2418      ( ( base + charid >=  ucharcount                                   \
2419          && base + charid < ubound                                      \
2420          && state == trie->trans[ base - ucharcount + charid ].check    \
2421          && trie->trans[ base - ucharcount + charid ].next )            \
2422            ? trie->trans[ base - ucharcount + charid ].next             \
2423            : ( state==1 ? special : 0 )                                 \
2424       )
2425
2426 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2427 STMT_START {                                                \
2428     TRIE_BITMAP_SET(trie, uvc);                             \
2429     /* store the folded codepoint */                        \
2430     if ( folder )                                           \
2431         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2432                                                             \
2433     if ( !UTF ) {                                           \
2434         /* store first byte of utf8 representation of */    \
2435         /* variant codepoints */                            \
2436         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2437             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2438         }                                                   \
2439     }                                                       \
2440 } STMT_END
2441 #define MADE_TRIE       1
2442 #define MADE_JUMP_TRIE  2
2443 #define MADE_EXACT_TRIE 4
2444
2445 STATIC I32
2446 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2447                   regnode *first, regnode *last, regnode *tail,
2448                   U32 word_count, U32 flags, U32 depth)
2449 {
2450     /* first pass, loop through and scan words */
2451     reg_trie_data *trie;
2452     HV *widecharmap = NULL;
2453     AV *revcharmap = newAV();
2454     regnode *cur;
2455     STRLEN len = 0;
2456     UV uvc = 0;
2457     U16 curword = 0;
2458     U32 next_alloc = 0;
2459     regnode *jumper = NULL;
2460     regnode *nextbranch = NULL;
2461     regnode *convert = NULL;
2462     U32 *prev_states; /* temp array mapping each state to previous one */
2463     /* we just use folder as a flag in utf8 */
2464     const U8 * folder = NULL;
2465
2466 #ifdef DEBUGGING
2467     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2468     AV *trie_words = NULL;
2469     /* along with revcharmap, this only used during construction but both are
2470      * useful during debugging so we store them in the struct when debugging.
2471      */
2472 #else
2473     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2474     STRLEN trie_charcount=0;
2475 #endif
2476     SV *re_trie_maxbuff;
2477     GET_RE_DEBUG_FLAGS_DECL;
2478
2479     PERL_ARGS_ASSERT_MAKE_TRIE;
2480 #ifndef DEBUGGING
2481     PERL_UNUSED_ARG(depth);
2482 #endif
2483
2484     switch (flags) {
2485         case EXACT: case EXACTL: break;
2486         case EXACTFA:
2487         case EXACTFU_SS:
2488         case EXACTFU:
2489         case EXACTFLU8: folder = PL_fold_latin1; break;
2490         case EXACTF:  folder = PL_fold; break;
2491         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2492     }
2493
2494     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2495     trie->refcount = 1;
2496     trie->startstate = 1;
2497     trie->wordcount = word_count;
2498     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2499     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2500     if (flags == EXACT || flags == EXACTL)
2501         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2502     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2503                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2504
2505     DEBUG_r({
2506         trie_words = newAV();
2507     });
2508
2509     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2510     assert(re_trie_maxbuff);
2511     if (!SvIOK(re_trie_maxbuff)) {
2512         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2513     }
2514     DEBUG_TRIE_COMPILE_r({
2515         Perl_re_indentf( aTHX_
2516           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2517           depth+1,
2518           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2519           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2520     });
2521
2522    /* Find the node we are going to overwrite */
2523     if ( first == startbranch && OP( last ) != BRANCH ) {
2524         /* whole branch chain */
2525         convert = first;
2526     } else {
2527         /* branch sub-chain */
2528         convert = NEXTOPER( first );
2529     }
2530
2531     /*  -- First loop and Setup --
2532
2533        We first traverse the branches and scan each word to determine if it
2534        contains widechars, and how many unique chars there are, this is
2535        important as we have to build a table with at least as many columns as we
2536        have unique chars.
2537
2538        We use an array of integers to represent the character codes 0..255
2539        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2540        the native representation of the character value as the key and IV's for
2541        the coded index.
2542
2543        *TODO* If we keep track of how many times each character is used we can
2544        remap the columns so that the table compression later on is more
2545        efficient in terms of memory by ensuring the most common value is in the
2546        middle and the least common are on the outside.  IMO this would be better
2547        than a most to least common mapping as theres a decent chance the most
2548        common letter will share a node with the least common, meaning the node
2549        will not be compressible. With a middle is most common approach the worst
2550        case is when we have the least common nodes twice.
2551
2552      */
2553
2554     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2555         regnode *noper = NEXTOPER( cur );
2556         const U8 *uc;
2557         const U8 *e;
2558         int foldlen = 0;
2559         U32 wordlen      = 0;         /* required init */
2560         STRLEN minchars = 0;
2561         STRLEN maxchars = 0;
2562         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2563                                                bitmap?*/
2564
2565         if (OP(noper) == NOTHING) {
2566             /* skip past a NOTHING at the start of an alternation
2567              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2568              */
2569             regnode *noper_next= regnext(noper);
2570             if (noper_next < tail)
2571                 noper= noper_next;
2572         }
2573
2574         if ( noper < tail &&
2575                 (
2576                     OP(noper) == flags ||
2577                     (
2578                         flags == EXACTFU &&
2579                         OP(noper) == EXACTFU_SS
2580                     )
2581                 )
2582         ) {
2583             uc= (U8*)STRING(noper);
2584             e= uc + STR_LEN(noper);
2585         } else {
2586             trie->minlen= 0;
2587             continue;
2588         }
2589
2590
2591         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2592             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2593                                           regardless of encoding */
2594             if (OP( noper ) == EXACTFU_SS) {
2595                 /* false positives are ok, so just set this */
2596                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2597             }
2598         }
2599
2600         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2601                                            branch */
2602             TRIE_CHARCOUNT(trie)++;
2603             TRIE_READ_CHAR;
2604
2605             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2606              * is in effect.  Under /i, this character can match itself, or
2607              * anything that folds to it.  If not under /i, it can match just
2608              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2609              * all fold to k, and all are single characters.   But some folds
2610              * expand to more than one character, so for example LATIN SMALL
2611              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2612              * the string beginning at 'uc' is 'ffi', it could be matched by
2613              * three characters, or just by the one ligature character. (It
2614              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2615              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2616              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2617              * match.)  The trie needs to know the minimum and maximum number
2618              * of characters that could match so that it can use size alone to
2619              * quickly reject many match attempts.  The max is simple: it is
2620              * the number of folded characters in this branch (since a fold is
2621              * never shorter than what folds to it. */
2622
2623             maxchars++;
2624
2625             /* And the min is equal to the max if not under /i (indicated by
2626              * 'folder' being NULL), or there are no multi-character folds.  If
2627              * there is a multi-character fold, the min is incremented just
2628              * once, for the character that folds to the sequence.  Each
2629              * character in the sequence needs to be added to the list below of
2630              * characters in the trie, but we count only the first towards the
2631              * min number of characters needed.  This is done through the
2632              * variable 'foldlen', which is returned by the macros that look
2633              * for these sequences as the number of bytes the sequence
2634              * occupies.  Each time through the loop, we decrement 'foldlen' by
2635              * how many bytes the current char occupies.  Only when it reaches
2636              * 0 do we increment 'minchars' or look for another multi-character
2637              * sequence. */
2638             if (folder == NULL) {
2639                 minchars++;
2640             }
2641             else if (foldlen > 0) {
2642                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2643             }
2644             else {
2645                 minchars++;
2646
2647                 /* See if *uc is the beginning of a multi-character fold.  If
2648                  * so, we decrement the length remaining to look at, to account
2649                  * for the current character this iteration.  (We can use 'uc'
2650                  * instead of the fold returned by TRIE_READ_CHAR because for
2651                  * non-UTF, the latin1_safe macro is smart enough to account
2652                  * for all the unfolded characters, and because for UTF, the
2653                  * string will already have been folded earlier in the
2654                  * compilation process */
2655                 if (UTF) {
2656                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2657                         foldlen -= UTF8SKIP(uc);
2658                     }
2659                 }
2660                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2661                     foldlen--;
2662                 }
2663             }
2664
2665             /* The current character (and any potential folds) should be added
2666              * to the possible matching characters for this position in this
2667              * branch */
2668             if ( uvc < 256 ) {
2669                 if ( folder ) {
2670                     U8 folded= folder[ (U8) uvc ];
2671                     if ( !trie->charmap[ folded ] ) {
2672                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2673                         TRIE_STORE_REVCHAR( folded );
2674                     }
2675                 }
2676                 if ( !trie->charmap[ uvc ] ) {
2677                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2678                     TRIE_STORE_REVCHAR( uvc );
2679                 }
2680                 if ( set_bit ) {
2681                     /* store the codepoint in the bitmap, and its folded
2682                      * equivalent. */
2683                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2684                     set_bit = 0; /* We've done our bit :-) */
2685                 }
2686             } else {
2687
2688                 /* XXX We could come up with the list of code points that fold
2689                  * to this using PL_utf8_foldclosures, except not for
2690                  * multi-char folds, as there may be multiple combinations
2691                  * there that could work, which needs to wait until runtime to
2692                  * resolve (The comment about LIGATURE FFI above is such an
2693                  * example */
2694
2695                 SV** svpp;
2696                 if ( !widecharmap )
2697                     widecharmap = newHV();
2698
2699                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2700
2701                 if ( !svpp )
2702                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2703
2704                 if ( !SvTRUE( *svpp ) ) {
2705                     sv_setiv( *svpp, ++trie->uniquecharcount );
2706                     TRIE_STORE_REVCHAR(uvc);
2707                 }
2708             }
2709         } /* end loop through characters in this branch of the trie */
2710
2711         /* We take the min and max for this branch and combine to find the min
2712          * and max for all branches processed so far */
2713         if( cur == first ) {
2714             trie->minlen = minchars;
2715             trie->maxlen = maxchars;
2716         } else if (minchars < trie->minlen) {
2717             trie->minlen = minchars;
2718         } else if (maxchars > trie->maxlen) {
2719             trie->maxlen = maxchars;
2720         }
2721     } /* end first pass */
2722     DEBUG_TRIE_COMPILE_r(
2723         Perl_re_indentf( aTHX_
2724                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2725                 depth+1,
2726                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2727                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2728                 (int)trie->minlen, (int)trie->maxlen )
2729     );
2730
2731     /*
2732         We now know what we are dealing with in terms of unique chars and
2733         string sizes so we can calculate how much memory a naive
2734         representation using a flat table  will take. If it's over a reasonable
2735         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2736         conservative but potentially much slower representation using an array
2737         of lists.
2738
2739         At the end we convert both representations into the same compressed
2740         form that will be used in regexec.c for matching with. The latter
2741         is a form that cannot be used to construct with but has memory
2742         properties similar to the list form and access properties similar
2743         to the table form making it both suitable for fast searches and
2744         small enough that its feasable to store for the duration of a program.
2745
2746         See the comment in the code where the compressed table is produced
2747         inplace from the flat tabe representation for an explanation of how
2748         the compression works.
2749
2750     */
2751
2752
2753     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2754     prev_states[1] = 0;
2755
2756     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2757                                                     > SvIV(re_trie_maxbuff) )
2758     {
2759         /*
2760             Second Pass -- Array Of Lists Representation
2761
2762             Each state will be represented by a list of charid:state records
2763             (reg_trie_trans_le) the first such element holds the CUR and LEN
2764             points of the allocated array. (See defines above).
2765
2766             We build the initial structure using the lists, and then convert
2767             it into the compressed table form which allows faster lookups
2768             (but cant be modified once converted).
2769         */
2770
2771         STRLEN transcount = 1;
2772
2773         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2774             depth+1));
2775
2776         trie->states = (reg_trie_state *)
2777             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2778                                   sizeof(reg_trie_state) );
2779         TRIE_LIST_NEW(1);
2780         next_alloc = 2;
2781
2782         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2783
2784             regnode *noper   = NEXTOPER( cur );
2785             U32 state        = 1;         /* required init */
2786             U16 charid       = 0;         /* sanity init */
2787             U32 wordlen      = 0;         /* required init */
2788
2789             if (OP(noper) == NOTHING) {
2790                 regnode *noper_next= regnext(noper);
2791                 if (noper_next < tail)
2792                     noper= noper_next;
2793             }
2794
2795             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2796                 const U8 *uc= (U8*)STRING(noper);
2797                 const U8 *e= uc + STR_LEN(noper);
2798
2799                 for ( ; uc < e ; uc += len ) {
2800
2801                     TRIE_READ_CHAR;
2802
2803                     if ( uvc < 256 ) {
2804                         charid = trie->charmap[ uvc ];
2805                     } else {
2806                         SV** const svpp = hv_fetch( widecharmap,
2807                                                     (char*)&uvc,
2808                                                     sizeof( UV ),
2809                                                     0);
2810                         if ( !svpp ) {
2811                             charid = 0;
2812                         } else {
2813                             charid=(U16)SvIV( *svpp );
2814                         }
2815                     }
2816                     /* charid is now 0 if we dont know the char read, or
2817                      * nonzero if we do */
2818                     if ( charid ) {
2819
2820                         U16 check;
2821                         U32 newstate = 0;
2822
2823                         charid--;
2824                         if ( !trie->states[ state ].trans.list ) {
2825                             TRIE_LIST_NEW( state );
2826                         }
2827                         for ( check = 1;
2828                               check <= TRIE_LIST_USED( state );
2829                               check++ )
2830                         {
2831                             if ( TRIE_LIST_ITEM( state, check ).forid
2832                                                                     == charid )
2833                             {
2834                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2835                                 break;
2836                             }
2837                         }
2838                         if ( ! newstate ) {
2839                             newstate = next_alloc++;
2840                             prev_states[newstate] = state;
2841                             TRIE_LIST_PUSH( state, charid, newstate );
2842                             transcount++;
2843                         }
2844                         state = newstate;
2845                     } else {
2846                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2847                     }
2848                 }
2849             }
2850             TRIE_HANDLE_WORD(state);
2851
2852         } /* end second pass */
2853
2854         /* next alloc is the NEXT state to be allocated */
2855         trie->statecount = next_alloc;
2856         trie->states = (reg_trie_state *)
2857             PerlMemShared_realloc( trie->states,
2858                                    next_alloc
2859                                    * sizeof(reg_trie_state) );
2860
2861         /* and now dump it out before we compress it */
2862         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2863                                                          revcharmap, next_alloc,
2864                                                          depth+1)
2865         );
2866
2867         trie->trans = (reg_trie_trans *)
2868             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2869         {
2870             U32 state;
2871             U32 tp = 0;
2872             U32 zp = 0;
2873
2874
2875             for( state=1 ; state < next_alloc ; state ++ ) {
2876                 U32 base=0;
2877
2878                 /*
2879                 DEBUG_TRIE_COMPILE_MORE_r(
2880                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2881                 );
2882                 */
2883
2884                 if (trie->states[state].trans.list) {
2885                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2886                     U16 maxid=minid;
2887                     U16 idx;
2888
2889                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2890                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2891                         if ( forid < minid ) {
2892                             minid=forid;
2893                         } else if ( forid > maxid ) {
2894                             maxid=forid;
2895                         }
2896                     }
2897                     if ( transcount < tp + maxid - minid + 1) {
2898                         transcount *= 2;
2899                         trie->trans = (reg_trie_trans *)
2900                             PerlMemShared_realloc( trie->trans,
2901                                                      transcount
2902                                                      * sizeof(reg_trie_trans) );
2903                         Zero( trie->trans + (transcount / 2),
2904                               transcount / 2,
2905                               reg_trie_trans );
2906                     }
2907                     base = trie->uniquecharcount + tp - minid;
2908                     if ( maxid == minid ) {
2909                         U32 set = 0;
2910                         for ( ; zp < tp ; zp++ ) {
2911                             if ( ! trie->trans[ zp ].next ) {
2912                                 base = trie->uniquecharcount + zp - minid;
2913                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2914                                                                    1).newstate;
2915                                 trie->trans[ zp ].check = state;
2916                                 set = 1;
2917                                 break;
2918                             }
2919                         }
2920                         if ( !set ) {
2921                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2922                                                                    1).newstate;
2923                             trie->trans[ tp ].check = state;
2924                             tp++;
2925                             zp = tp;
2926                         }
2927                     } else {
2928                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2929                             const U32 tid = base
2930                                            - trie->uniquecharcount
2931                                            + TRIE_LIST_ITEM( state, idx ).forid;
2932                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2933                                                                 idx ).newstate;
2934                             trie->trans[ tid ].check = state;
2935                         }
2936                         tp += ( maxid - minid + 1 );
2937                     }
2938                     Safefree(trie->states[ state ].trans.list);
2939                 }
2940                 /*
2941                 DEBUG_TRIE_COMPILE_MORE_r(
2942                     Perl_re_printf( aTHX_  " base: %d\n",base);
2943                 );
2944                 */
2945                 trie->states[ state ].trans.base=base;
2946             }
2947             trie->lasttrans = tp + 1;
2948         }
2949     } else {
2950         /*
2951            Second Pass -- Flat Table Representation.
2952
2953            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2954            each.  We know that we will need Charcount+1 trans at most to store
2955            the data (one row per char at worst case) So we preallocate both
2956            structures assuming worst case.
2957
2958            We then construct the trie using only the .next slots of the entry
2959            structs.
2960
2961            We use the .check field of the first entry of the node temporarily
2962            to make compression both faster and easier by keeping track of how
2963            many non zero fields are in the node.
2964
2965            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2966            transition.
2967
2968            There are two terms at use here: state as a TRIE_NODEIDX() which is
2969            a number representing the first entry of the node, and state as a
2970            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2971            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2972            if there are 2 entrys per node. eg:
2973
2974              A B       A B
2975           1. 2 4    1. 3 7
2976           2. 0 3    3. 0 5
2977           3. 0 0    5. 0 0
2978           4. 0 0    7. 0 0
2979
2980            The table is internally in the right hand, idx form. However as we
2981            also have to deal with the states array which is indexed by nodenum
2982            we have to use TRIE_NODENUM() to convert.
2983
2984         */
2985         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
2986             depth+1));
2987
2988         trie->trans = (reg_trie_trans *)
2989             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2990                                   * trie->uniquecharcount + 1,
2991                                   sizeof(reg_trie_trans) );
2992         trie->states = (reg_trie_state *)
2993             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2994                                   sizeof(reg_trie_state) );
2995         next_alloc = trie->uniquecharcount + 1;
2996
2997
2998         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2999
3000             regnode *noper   = NEXTOPER( cur );
3001
3002             U32 state        = 1;         /* required init */
3003
3004             U16 charid       = 0;         /* sanity init */
3005             U32 accept_state = 0;         /* sanity init */
3006
3007             U32 wordlen      = 0;         /* required init */
3008
3009             if (OP(noper) == NOTHING) {
3010                 regnode *noper_next= regnext(noper);
3011                 if (noper_next < tail)
3012                     noper= noper_next;
3013             }
3014
3015             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3016                 const U8 *uc= (U8*)STRING(noper);
3017                 const U8 *e= uc + STR_LEN(noper);
3018
3019                 for ( ; uc < e ; uc += len ) {
3020
3021                     TRIE_READ_CHAR;
3022
3023                     if ( uvc < 256 ) {
3024                         charid = trie->charmap[ uvc ];
3025                     } else {
3026                         SV* const * const svpp = hv_fetch( widecharmap,
3027                                                            (char*)&uvc,
3028                                                            sizeof( UV ),
3029                                                            0);
3030                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3031                     }
3032                     if ( charid ) {
3033                         charid--;
3034                         if ( !trie->trans[ state + charid ].next ) {
3035                             trie->trans[ state + charid ].next = next_alloc;
3036                             trie->trans[ state ].check++;
3037                             prev_states[TRIE_NODENUM(next_alloc)]
3038                                     = TRIE_NODENUM(state);
3039                             next_alloc += trie->uniquecharcount;
3040                         }
3041                         state = trie->trans[ state + charid ].next;
3042                     } else {
3043                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3044                     }
3045                     /* charid is now 0 if we dont know the char read, or
3046                      * nonzero if we do */
3047                 }
3048             }
3049             accept_state = TRIE_NODENUM( state );
3050             TRIE_HANDLE_WORD(accept_state);
3051
3052         } /* end second pass */
3053
3054         /* and now dump it out before we compress it */
3055         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3056                                                           revcharmap,
3057                                                           next_alloc, depth+1));
3058
3059         {
3060         /*
3061            * Inplace compress the table.*
3062
3063            For sparse data sets the table constructed by the trie algorithm will
3064            be mostly 0/FAIL transitions or to put it another way mostly empty.
3065            (Note that leaf nodes will not contain any transitions.)
3066
3067            This algorithm compresses the tables by eliminating most such
3068            transitions, at the cost of a modest bit of extra work during lookup:
3069
3070            - Each states[] entry contains a .base field which indicates the
3071            index in the state[] array wheres its transition data is stored.
3072
3073            - If .base is 0 there are no valid transitions from that node.
3074
3075            - If .base is nonzero then charid is added to it to find an entry in
3076            the trans array.
3077
3078            -If trans[states[state].base+charid].check!=state then the
3079            transition is taken to be a 0/Fail transition. Thus if there are fail
3080            transitions at the front of the node then the .base offset will point
3081            somewhere inside the previous nodes data (or maybe even into a node
3082            even earlier), but the .check field determines if the transition is
3083            valid.
3084
3085            XXX - wrong maybe?
3086            The following process inplace converts the table to the compressed
3087            table: We first do not compress the root node 1,and mark all its
3088            .check pointers as 1 and set its .base pointer as 1 as well. This
3089            allows us to do a DFA construction from the compressed table later,
3090            and ensures that any .base pointers we calculate later are greater
3091            than 0.
3092
3093            - We set 'pos' to indicate the first entry of the second node.
3094
3095            - We then iterate over the columns of the node, finding the first and
3096            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3097            and set the .check pointers accordingly, and advance pos
3098            appropriately and repreat for the next node. Note that when we copy
3099            the next pointers we have to convert them from the original
3100            NODEIDX form to NODENUM form as the former is not valid post
3101            compression.
3102
3103            - If a node has no transitions used we mark its base as 0 and do not
3104            advance the pos pointer.
3105
3106            - If a node only has one transition we use a second pointer into the
3107            structure to fill in allocated fail transitions from other states.
3108            This pointer is independent of the main pointer and scans forward
3109            looking for null transitions that are allocated to a state. When it
3110            finds one it writes the single transition into the "hole".  If the
3111            pointer doesnt find one the single transition is appended as normal.
3112
3113            - Once compressed we can Renew/realloc the structures to release the
3114            excess space.
3115
3116            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3117            specifically Fig 3.47 and the associated pseudocode.
3118
3119            demq
3120         */
3121         const U32 laststate = TRIE_NODENUM( next_alloc );
3122         U32 state, charid;
3123         U32 pos = 0, zp=0;
3124         trie->statecount = laststate;
3125
3126         for ( state = 1 ; state < laststate ; state++ ) {
3127             U8 flag = 0;
3128             const U32 stateidx = TRIE_NODEIDX( state );
3129             const U32 o_used = trie->trans[ stateidx ].check;
3130             U32 used = trie->trans[ stateidx ].check;
3131             trie->trans[ stateidx ].check = 0;
3132
3133             for ( charid = 0;
3134                   used && charid < trie->uniquecharcount;
3135                   charid++ )
3136             {
3137                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3138                     if ( trie->trans[ stateidx + charid ].next ) {
3139                         if (o_used == 1) {
3140                             for ( ; zp < pos ; zp++ ) {
3141                                 if ( ! trie->trans[ zp ].next ) {
3142                                     break;
3143                                 }
3144                             }
3145                             trie->states[ state ].trans.base
3146                                                     = zp
3147                                                       + trie->uniquecharcount
3148                                                       - charid ;
3149                             trie->trans[ zp ].next
3150                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3151                                                              + charid ].next );
3152                             trie->trans[ zp ].check = state;
3153                             if ( ++zp > pos ) pos = zp;
3154                             break;
3155                         }
3156                         used--;
3157                     }
3158                     if ( !flag ) {
3159                         flag = 1;
3160                         trie->states[ state ].trans.base
3161                                        = pos + trie->uniquecharcount - charid ;
3162                     }
3163                     trie->trans[ pos ].next
3164                         = SAFE_TRIE_NODENUM(
3165                                        trie->trans[ stateidx + charid ].next );
3166                     trie->trans[ pos ].check = state;
3167                     pos++;
3168                 }
3169             }
3170         }
3171         trie->lasttrans = pos + 1;
3172         trie->states = (reg_trie_state *)
3173             PerlMemShared_realloc( trie->states, laststate
3174                                    * sizeof(reg_trie_state) );
3175         DEBUG_TRIE_COMPILE_MORE_r(
3176             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3177                 depth+1,
3178                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3179                        + 1 ),
3180                 (IV)next_alloc,
3181                 (IV)pos,
3182                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3183             );
3184
3185         } /* end table compress */
3186     }
3187     DEBUG_TRIE_COMPILE_MORE_r(
3188             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3189                 depth+1,
3190                 (UV)trie->statecount,
3191                 (UV)trie->lasttrans)
3192     );
3193     /* resize the trans array to remove unused space */
3194     trie->trans = (reg_trie_trans *)
3195         PerlMemShared_realloc( trie->trans, trie->lasttrans
3196                                * sizeof(reg_trie_trans) );
3197
3198     {   /* Modify the program and insert the new TRIE node */
3199         U8 nodetype =(U8)(flags & 0xFF);
3200         char *str=NULL;
3201
3202 #ifdef DEBUGGING
3203         regnode *optimize = NULL;
3204 #ifdef RE_TRACK_PATTERN_OFFSETS
3205
3206         U32 mjd_offset = 0;
3207         U32 mjd_nodelen = 0;
3208 #endif /* RE_TRACK_PATTERN_OFFSETS */
3209 #endif /* DEBUGGING */
3210         /*
3211            This means we convert either the first branch or the first Exact,
3212            depending on whether the thing following (in 'last') is a branch
3213            or not and whther first is the startbranch (ie is it a sub part of
3214            the alternation or is it the whole thing.)
3215            Assuming its a sub part we convert the EXACT otherwise we convert
3216            the whole branch sequence, including the first.
3217          */
3218         /* Find the node we are going to overwrite */
3219         if ( first != startbranch || OP( last ) == BRANCH ) {
3220             /* branch sub-chain */
3221             NEXT_OFF( first ) = (U16)(last - first);
3222 #ifdef RE_TRACK_PATTERN_OFFSETS
3223             DEBUG_r({
3224                 mjd_offset= Node_Offset((convert));
3225                 mjd_nodelen= Node_Length((convert));
3226             });
3227 #endif
3228             /* whole branch chain */
3229         }
3230 #ifdef RE_TRACK_PATTERN_OFFSETS
3231         else {
3232             DEBUG_r({
3233                 const  regnode *nop = NEXTOPER( convert );
3234                 mjd_offset= Node_Offset((nop));
3235                 mjd_nodelen= Node_Length((nop));
3236             });
3237         }
3238         DEBUG_OPTIMISE_r(
3239             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3240                 depth+1,
3241                 (UV)mjd_offset, (UV)mjd_nodelen)
3242         );
3243 #endif
3244         /* But first we check to see if there is a common prefix we can
3245            split out as an EXACT and put in front of the TRIE node.  */
3246         trie->startstate= 1;
3247         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3248             /* we want to find the first state that has more than
3249              * one transition, if that state is not the first state
3250              * then we have a common prefix which we can remove.
3251              */
3252             U32 state;
3253             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3254                 U32 ofs = 0;
3255                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3256                                        transition, -1 means none */
3257                 U32 count = 0;
3258                 const U32 base = trie->states[ state ].trans.base;
3259
3260                 /* does this state terminate an alternation? */
3261                 if ( trie->states[state].wordnum )
3262                         count = 1;
3263
3264                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3265                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3266                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3267                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3268                     {
3269                         if ( ++count > 1 ) {
3270                             /* we have more than one transition */
3271                             SV **tmp;
3272                             U8 *ch;
3273                             /* if this is the first state there is no common prefix
3274                              * to extract, so we can exit */
3275                             if ( state == 1 ) break;
3276                             tmp = av_fetch( revcharmap, ofs, 0);
3277                             ch = (U8*)SvPV_nolen_const( *tmp );
3278
3279                             /* if we are on count 2 then we need to initialize the
3280                              * bitmap, and store the previous char if there was one
3281                              * in it*/
3282                             if ( count == 2 ) {
3283                                 /* clear the bitmap */
3284                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3285                                 DEBUG_OPTIMISE_r(
3286                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3287                                         depth+1,
3288                                         (UV)state));
3289                                 if (first_ofs >= 0) {
3290                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3291                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3292
3293                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3294                                     DEBUG_OPTIMISE_r(
3295                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3296                                     );
3297                                 }
3298                             }
3299                             /* store the current firstchar in the bitmap */
3300                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3301                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3302                         }
3303                         first_ofs = ofs;
3304                     }
3305                 }
3306                 if ( count == 1 ) {
3307                     /* This state has only one transition, its transition is part
3308                      * of a common prefix - we need to concatenate the char it
3309                      * represents to what we have so far. */
3310                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3311                     STRLEN len;
3312                     char *ch = SvPV( *tmp, len );
3313                     DEBUG_OPTIMISE_r({
3314                         SV *sv=sv_newmortal();
3315                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3316                             depth+1,
3317                             (UV)state, (UV)first_ofs,
3318                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3319                                 PL_colors[0], PL_colors[1],
3320                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3321                                 PERL_PV_ESCAPE_FIRSTCHAR
3322                             )
3323                         );
3324                     });
3325                     if ( state==1 ) {
3326                         OP( convert ) = nodetype;
3327                         str=STRING(convert);
3328                         STR_LEN(convert)=0;
3329                     }
3330                     STR_LEN(convert) += len;
3331                     while (len--)
3332                         *str++ = *ch++;
3333                 } else {
3334 #ifdef DEBUGGING
3335                     if (state>1)
3336                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3337 #endif
3338                     break;
3339                 }
3340             }
3341             trie->prefixlen = (state-1);
3342             if (str) {
3343                 regnode *n = convert+NODE_SZ_STR(convert);
3344                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3345                 trie->startstate = state;
3346                 trie->minlen -= (state - 1);
3347                 trie->maxlen -= (state - 1);
3348 #ifdef DEBUGGING
3349                /* At least the UNICOS C compiler choked on this
3350                 * being argument to DEBUG_r(), so let's just have
3351                 * it right here. */
3352                if (
3353 #ifdef PERL_EXT_RE_BUILD
3354                    1
3355 #else
3356                    DEBUG_r_TEST
3357 #endif
3358                    ) {
3359                    regnode *fix = convert;
3360                    U32 word = trie->wordcount;
3361                    mjd_nodelen++;
3362                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3363                    while( ++fix < n ) {
3364                        Set_Node_Offset_Length(fix, 0, 0);
3365                    }
3366                    while (word--) {
3367                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3368                        if (tmp) {
3369                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3370                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3371                            else
3372                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3373                        }
3374                    }
3375                }
3376 #endif
3377                 if (trie->maxlen) {
3378                     convert = n;
3379                 } else {
3380                     NEXT_OFF(convert) = (U16)(tail - convert);
3381                     DEBUG_r(optimize= n);
3382                 }
3383             }
3384         }
3385         if (!jumper)
3386             jumper = last;
3387         if ( trie->maxlen ) {
3388             NEXT_OFF( convert ) = (U16)(tail - convert);
3389             ARG_SET( convert, data_slot );
3390             /* Store the offset to the first unabsorbed branch in
3391                jump[0], which is otherwise unused by the jump logic.
3392                We use this when dumping a trie and during optimisation. */
3393             if (trie->jump)
3394                 trie->jump[0] = (U16)(nextbranch - convert);
3395
3396             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3397              *   and there is a bitmap
3398              *   and the first "jump target" node we found leaves enough room
3399              * then convert the TRIE node into a TRIEC node, with the bitmap
3400              * embedded inline in the opcode - this is hypothetically faster.
3401              */
3402             if ( !trie->states[trie->startstate].wordnum
3403                  && trie->bitmap
3404                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3405             {
3406                 OP( convert ) = TRIEC;
3407                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3408                 PerlMemShared_free(trie->bitmap);
3409                 trie->bitmap= NULL;
3410             } else
3411                 OP( convert ) = TRIE;
3412
3413             /* store the type in the flags */
3414             convert->flags = nodetype;
3415             DEBUG_r({
3416             optimize = convert
3417                       + NODE_STEP_REGNODE
3418                       + regarglen[ OP( convert ) ];
3419             });
3420             /* XXX We really should free up the resource in trie now,
3421                    as we won't use them - (which resources?) dmq */
3422         }
3423         /* needed for dumping*/
3424         DEBUG_r(if (optimize) {
3425             regnode *opt = convert;
3426
3427             while ( ++opt < optimize) {
3428                 Set_Node_Offset_Length(opt,0,0);
3429             }
3430             /*
3431                 Try to clean up some of the debris left after the
3432                 optimisation.
3433              */
3434             while( optimize < jumper ) {
3435                 mjd_nodelen += Node_Length((optimize));
3436                 OP( optimize ) = OPTIMIZED;
3437                 Set_Node_Offset_Length(optimize,0,0);
3438                 optimize++;
3439             }
3440             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3441         });
3442     } /* end node insert */
3443
3444     /*  Finish populating the prev field of the wordinfo array.  Walk back
3445      *  from each accept state until we find another accept state, and if
3446      *  so, point the first word's .prev field at the second word. If the
3447      *  second already has a .prev field set, stop now. This will be the
3448      *  case either if we've already processed that word's accept state,
3449      *  or that state had multiple words, and the overspill words were
3450      *  already linked up earlier.
3451      */
3452     {
3453         U16 word;
3454         U32 state;
3455         U16 prev;
3456
3457         for (word=1; word <= trie->wordcount; word++) {
3458             prev = 0;
3459             if (trie->wordinfo[word].prev)
3460                 continue;
3461             state = trie->wordinfo[word].accept;
3462             while (state) {
3463                 state = prev_states[state];
3464                 if (!state)
3465                     break;
3466                 prev = trie->states[state].wordnum;
3467                 if (prev)
3468                     break;
3469             }
3470             trie->wordinfo[word].prev = prev;
3471         }
3472         Safefree(prev_states);
3473     }
3474
3475
3476     /* and now dump out the compressed format */
3477     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3478
3479     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3480 #ifdef DEBUGGING
3481     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3482     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3483 #else
3484     SvREFCNT_dec_NN(revcharmap);
3485 #endif
3486     return trie->jump
3487            ? MADE_JUMP_TRIE
3488            : trie->startstate>1
3489              ? MADE_EXACT_TRIE
3490              : MADE_TRIE;
3491 }
3492
3493 STATIC regnode *
3494 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3495 {
3496 /* The Trie is constructed and compressed now so we can build a fail array if
3497  * it's needed
3498
3499    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3500    3.32 in the
3501    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3502    Ullman 1985/88
3503    ISBN 0-201-10088-6
3504
3505    We find the fail state for each state in the trie, this state is the longest
3506    proper suffix of the current state's 'word' that is also a proper prefix of
3507    another word in our trie. State 1 represents the word '' and is thus the
3508    default fail state. This allows the DFA not to have to restart after its
3509    tried and failed a word at a given point, it simply continues as though it
3510    had been matching the other word in the first place.
3511    Consider
3512       'abcdgu'=~/abcdefg|cdgu/
3513    When we get to 'd' we are still matching the first word, we would encounter
3514    'g' which would fail, which would bring us to the state representing 'd' in
3515    the second word where we would try 'g' and succeed, proceeding to match
3516    'cdgu'.
3517  */
3518  /* add a fail transition */
3519     const U32 trie_offset = ARG(source);
3520     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3521     U32 *q;
3522     const U32 ucharcount = trie->uniquecharcount;
3523     const U32 numstates = trie->statecount;
3524     const U32 ubound = trie->lasttrans + ucharcount;
3525     U32 q_read = 0;
3526     U32 q_write = 0;
3527     U32 charid;
3528     U32 base = trie->states[ 1 ].trans.base;
3529     U32 *fail;
3530     reg_ac_data *aho;
3531     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3532     regnode *stclass;
3533     GET_RE_DEBUG_FLAGS_DECL;
3534
3535     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3536     PERL_UNUSED_CONTEXT;
3537 #ifndef DEBUGGING
3538     PERL_UNUSED_ARG(depth);
3539 #endif
3540
3541     if ( OP(source) == TRIE ) {
3542         struct regnode_1 *op = (struct regnode_1 *)
3543             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3544         StructCopy(source,op,struct regnode_1);
3545         stclass = (regnode *)op;
3546     } else {
3547         struct regnode_charclass *op = (struct regnode_charclass *)
3548             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3549         StructCopy(source,op,struct regnode_charclass);
3550         stclass = (regnode *)op;
3551     }
3552     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3553
3554     ARG_SET( stclass, data_slot );
3555     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3556     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3557     aho->trie=trie_offset;
3558     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3559     Copy( trie->states, aho->states, numstates, reg_trie_state );
3560     Newxz( q, numstates, U32);
3561     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3562     aho->refcount = 1;
3563     fail = aho->fail;
3564     /* initialize fail[0..1] to be 1 so that we always have
3565        a valid final fail state */
3566     fail[ 0 ] = fail[ 1 ] = 1;
3567
3568     for ( charid = 0; charid < ucharcount ; charid++ ) {
3569         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3570         if ( newstate ) {
3571             q[ q_write ] = newstate;
3572             /* set to point at the root */
3573             fail[ q[ q_write++ ] ]=1;
3574         }
3575     }
3576     while ( q_read < q_write) {
3577         const U32 cur = q[ q_read++ % numstates ];
3578         base = trie->states[ cur ].trans.base;
3579
3580         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3581             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3582             if (ch_state) {
3583                 U32 fail_state = cur;
3584                 U32 fail_base;
3585                 do {
3586                     fail_state = fail[ fail_state ];
3587                     fail_base = aho->states[ fail_state ].trans.base;
3588                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3589
3590                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3591                 fail[ ch_state ] = fail_state;
3592                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3593                 {
3594                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3595                 }
3596                 q[ q_write++ % numstates] = ch_state;
3597             }
3598         }
3599     }
3600     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3601        when we fail in state 1, this allows us to use the
3602        charclass scan to find a valid start char. This is based on the principle
3603        that theres a good chance the string being searched contains lots of stuff
3604        that cant be a start char.
3605      */
3606     fail[ 0 ] = fail[ 1 ] = 0;
3607     DEBUG_TRIE_COMPILE_r({
3608         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3609                       depth, (UV)numstates
3610         );
3611         for( q_read=1; q_read<numstates; q_read++ ) {
3612             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3613         }
3614         Perl_re_printf( aTHX_  "\n");
3615     });
3616     Safefree(q);
3617     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3618     return stclass;
3619 }
3620
3621
3622 #define DEBUG_PEEP(str,scan,depth)         \
3623     DEBUG_OPTIMISE_r({if (scan){           \
3624        regnode *Next = regnext(scan);      \
3625        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);\
3626        Perl_re_indentf( aTHX_  "" str ">%3d: %s (%d)", \
3627            depth, REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3628            Next ? (REG_NODE_NUM(Next)) : 0 );\
3629        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3630        Perl_re_printf( aTHX_  "\n");                   \
3631    }});
3632
3633 /* The below joins as many adjacent EXACTish nodes as possible into a single
3634  * one.  The regop may be changed if the node(s) contain certain sequences that
3635  * require special handling.  The joining is only done if:
3636  * 1) there is room in the current conglomerated node to entirely contain the
3637  *    next one.
3638  * 2) they are the exact same node type
3639  *
3640  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3641  * these get optimized out
3642  *
3643  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3644  * as possible, even if that means splitting an existing node so that its first
3645  * part is moved to the preceeding node.  This would maximise the efficiency of
3646  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3647  * EXACTFish nodes into portions that don't change under folding vs those that
3648  * do.  Those portions that don't change may be the only things in the pattern that
3649  * could be used to find fixed and floating strings.
3650  *
3651  * If a node is to match under /i (folded), the number of characters it matches
3652  * can be different than its character length if it contains a multi-character
3653  * fold.  *min_subtract is set to the total delta number of characters of the
3654  * input nodes.
3655  *
3656  * And *unfolded_multi_char is set to indicate whether or not the node contains
3657  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3658  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3659  * SMALL LETTER SHARP S, as only if the target string being matched against
3660  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3661  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3662  * whose components are all above the Latin1 range are not run-time locale
3663  * dependent, and have already been folded by the time this function is
3664  * called.)
3665  *
3666  * This is as good a place as any to discuss the design of handling these
3667  * multi-character fold sequences.  It's been wrong in Perl for a very long
3668  * time.  There are three code points in Unicode whose multi-character folds
3669  * were long ago discovered to mess things up.  The previous designs for
3670  * dealing with these involved assigning a special node for them.  This
3671  * approach doesn't always work, as evidenced by this example:
3672  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3673  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3674  * would match just the \xDF, it won't be able to handle the case where a
3675  * successful match would have to cross the node's boundary.  The new approach
3676  * that hopefully generally solves the problem generates an EXACTFU_SS node
3677  * that is "sss" in this case.
3678  *
3679  * It turns out that there are problems with all multi-character folds, and not
3680  * just these three.  Now the code is general, for all such cases.  The
3681  * approach taken is:
3682  * 1)   This routine examines each EXACTFish node that could contain multi-
3683  *      character folded sequences.  Since a single character can fold into
3684  *      such a sequence, the minimum match length for this node is less than
3685  *      the number of characters in the node.  This routine returns in
3686  *      *min_subtract how many characters to subtract from the the actual
3687  *      length of the string to get a real minimum match length; it is 0 if
3688  *      there are no multi-char foldeds.  This delta is used by the caller to
3689  *      adjust the min length of the match, and the delta between min and max,
3690  *      so that the optimizer doesn't reject these possibilities based on size
3691  *      constraints.
3692  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3693  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3694  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3695  *      there is a possible fold length change.  That means that a regular
3696  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3697  *      with length changes, and so can be processed faster.  regexec.c takes
3698  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3699  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3700  *      known until runtime).  This saves effort in regex matching.  However,
3701  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3702  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3703  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3704  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3705  *      possibilities for the non-UTF8 patterns are quite simple, except for
3706  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3707  *      members of a fold-pair, and arrays are set up for all of them so that
3708  *      the other member of the pair can be found quickly.  Code elsewhere in
3709  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3710  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3711  *      described in the next item.
3712  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3713  *      validity of the fold won't be known until runtime, and so must remain
3714  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3715  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3716  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3717  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3718  *      The reason this is a problem is that the optimizer part of regexec.c
3719  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3720  *      that a character in the pattern corresponds to at most a single
3721  *      character in the target string.  (And I do mean character, and not byte
3722  *      here, unlike other parts of the documentation that have never been
3723  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3724  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3725  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3726  *      nodes, violate the assumption, and they are the only instances where it
3727  *      is violated.  I'm reluctant to try to change the assumption, as the
3728  *      code involved is impenetrable to me (khw), so instead the code here
3729  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3730  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3731  *      boolean indicating whether or not the node contains such a fold.  When
3732  *      it is true, the caller sets a flag that later causes the optimizer in
3733  *      this file to not set values for the floating and fixed string lengths,
3734  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3735  *      assumption.  Thus, there is no optimization based on string lengths for
3736  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3737  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3738  *      assumption is wrong only in these cases is that all other non-UTF-8
3739  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3740  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3741  *      EXACTF nodes because we don't know at compile time if it actually
3742  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3743  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3744  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3745  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3746  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3747  *      string would require the pattern to be forced into UTF-8, the overhead
3748  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3749  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3750  *      locale.)
3751  *
3752  *      Similarly, the code that generates tries doesn't currently handle
3753  *      not-already-folded multi-char folds, and it looks like a pain to change
3754  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3755  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3756  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3757  *      using /iaa matching will be doing so almost entirely with ASCII
3758  *      strings, so this should rarely be encountered in practice */
3759
3760 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3761     if (PL_regkind[OP(scan)] == EXACT) \
3762         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3763
3764 STATIC U32
3765 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3766                    UV *min_subtract, bool *unfolded_multi_char,
3767                    U32 flags,regnode *val, U32 depth)
3768 {
3769     /* Merge several consecutive EXACTish nodes into one. */
3770     regnode *n = regnext(scan);
3771     U32 stringok = 1;
3772     regnode *next = scan + NODE_SZ_STR(scan);
3773     U32 merged = 0;
3774     U32 stopnow = 0;
3775 #ifdef DEBUGGING
3776     regnode *stop = scan;
3777     GET_RE_DEBUG_FLAGS_DECL;
3778 #else
3779     PERL_UNUSED_ARG(depth);
3780 #endif
3781
3782     PERL_ARGS_ASSERT_JOIN_EXACT;
3783 #ifndef EXPERIMENTAL_INPLACESCAN
3784     PERL_UNUSED_ARG(flags);
3785     PERL_UNUSED_ARG(val);
3786 #endif
3787     DEBUG_PEEP("join",scan,depth);
3788
3789     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3790      * EXACT ones that are mergeable to the current one. */
3791     while (n
3792            && (PL_regkind[OP(n)] == NOTHING
3793                || (stringok && OP(n) == OP(scan)))
3794            && NEXT_OFF(n)
3795            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3796     {
3797
3798         if (OP(n) == TAIL || n > next)
3799             stringok = 0;
3800         if (PL_regkind[OP(n)] == NOTHING) {
3801             DEBUG_PEEP("skip:",n,depth);
3802             NEXT_OFF(scan) += NEXT_OFF(n);
3803             next = n + NODE_STEP_REGNODE;
3804 #ifdef DEBUGGING
3805             if (stringok)
3806                 stop = n;
3807 #endif
3808             n = regnext(n);
3809         }
3810         else if (stringok) {
3811             const unsigned int oldl = STR_LEN(scan);
3812             regnode * const nnext = regnext(n);
3813
3814             /* XXX I (khw) kind of doubt that this works on platforms (should
3815              * Perl ever run on one) where U8_MAX is above 255 because of lots
3816              * of other assumptions */
3817             /* Don't join if the sum can't fit into a single node */
3818             if (oldl + STR_LEN(n) > U8_MAX)
3819                 break;
3820
3821             DEBUG_PEEP("merg",n,depth);
3822             merged++;
3823
3824             NEXT_OFF(scan) += NEXT_OFF(n);
3825             STR_LEN(scan) += STR_LEN(n);
3826             next = n + NODE_SZ_STR(n);
3827             /* Now we can overwrite *n : */
3828             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3829 #ifdef DEBUGGING
3830             stop = next - 1;
3831 #endif
3832             n = nnext;
3833             if (stopnow) break;
3834         }
3835
3836 #ifdef EXPERIMENTAL_INPLACESCAN
3837         if (flags && !NEXT_OFF(n)) {
3838             DEBUG_PEEP("atch", val, depth);
3839             if (reg_off_by_arg[OP(n)]) {
3840                 ARG_SET(n, val - n);
3841             }
3842             else {
3843                 NEXT_OFF(n) = val - n;
3844             }
3845             stopnow = 1;
3846         }
3847 #endif
3848     }
3849
3850     *min_subtract = 0;
3851     *unfolded_multi_char = FALSE;
3852
3853     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3854      * can now analyze for sequences of problematic code points.  (Prior to
3855      * this final joining, sequences could have been split over boundaries, and
3856      * hence missed).  The sequences only happen in folding, hence for any
3857      * non-EXACT EXACTish node */
3858     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3859         U8* s0 = (U8*) STRING(scan);
3860         U8* s = s0;
3861         U8* s_end = s0 + STR_LEN(scan);
3862
3863         int total_count_delta = 0;  /* Total delta number of characters that
3864                                        multi-char folds expand to */
3865
3866         /* One pass is made over the node's string looking for all the
3867          * possibilities.  To avoid some tests in the loop, there are two main
3868          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3869          * non-UTF-8 */
3870         if (UTF) {
3871             U8* folded = NULL;
3872
3873             if (OP(scan) == EXACTFL) {
3874                 U8 *d;
3875
3876                 /* An EXACTFL node would already have been changed to another
3877                  * node type unless there is at least one character in it that
3878                  * is problematic; likely a character whose fold definition
3879                  * won't be known until runtime, and so has yet to be folded.
3880                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3881                  * to handle the UTF-8 case, we need to create a temporary
3882                  * folded copy using UTF-8 locale rules in order to analyze it.
3883                  * This is because our macros that look to see if a sequence is
3884                  * a multi-char fold assume everything is folded (otherwise the
3885                  * tests in those macros would be too complicated and slow).
3886                  * Note that here, the non-problematic folds will have already
3887                  * been done, so we can just copy such characters.  We actually
3888                  * don't completely fold the EXACTFL string.  We skip the
3889                  * unfolded multi-char folds, as that would just create work
3890                  * below to figure out the size they already are */
3891
3892                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3893                 d = folded;
3894                 while (s < s_end) {
3895                     STRLEN s_len = UTF8SKIP(s);
3896                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3897                         Copy(s, d, s_len, U8);
3898                         d += s_len;
3899                     }
3900                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3901                         *unfolded_multi_char = TRUE;
3902                         Copy(s, d, s_len, U8);
3903                         d += s_len;
3904                     }
3905                     else if (isASCII(*s)) {
3906                         *(d++) = toFOLD(*s);
3907                     }
3908                     else {
3909                         STRLEN len;
3910                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
3911                         d += len;
3912                     }
3913                     s += s_len;
3914                 }
3915
3916                 /* Point the remainder of the routine to look at our temporary
3917                  * folded copy */
3918                 s = folded;
3919                 s_end = d;
3920             } /* End of creating folded copy of EXACTFL string */
3921
3922             /* Examine the string for a multi-character fold sequence.  UTF-8
3923              * patterns have all characters pre-folded by the time this code is
3924              * executed */
3925             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3926                                      length sequence we are looking for is 2 */
3927             {
3928                 int count = 0;  /* How many characters in a multi-char fold */
3929                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3930                 if (! len) {    /* Not a multi-char fold: get next char */
3931                     s += UTF8SKIP(s);
3932                     continue;
3933                 }
3934
3935                 /* Nodes with 'ss' require special handling, except for
3936                  * EXACTFA-ish for which there is no multi-char fold to this */
3937                 if (len == 2 && *s == 's' && *(s+1) == 's'
3938                     && OP(scan) != EXACTFA
3939                     && OP(scan) != EXACTFA_NO_TRIE)
3940                 {
3941                     count = 2;
3942                     if (OP(scan) != EXACTFL) {
3943                         OP(scan) = EXACTFU_SS;
3944                     }
3945                     s += 2;
3946                 }
3947                 else { /* Here is a generic multi-char fold. */
3948                     U8* multi_end  = s + len;
3949
3950                     /* Count how many characters are in it.  In the case of
3951                      * /aa, no folds which contain ASCII code points are
3952                      * allowed, so check for those, and skip if found. */
3953                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3954                         count = utf8_length(s, multi_end);
3955                         s = multi_end;
3956                     }
3957                     else {
3958                         while (s < multi_end) {
3959                             if (isASCII(*s)) {
3960                                 s++;
3961                                 goto next_iteration;
3962                             }
3963                             else {
3964                                 s += UTF8SKIP(s);
3965                             }
3966                             count++;
3967                         }
3968                     }
3969                 }
3970
3971                 /* The delta is how long the sequence is minus 1 (1 is how long
3972                  * the character that folds to the sequence is) */
3973                 total_count_delta += count - 1;
3974               next_iteration: ;
3975             }
3976
3977             /* We created a temporary folded copy of the string in EXACTFL
3978              * nodes.  Therefore we need to be sure it doesn't go below zero,
3979              * as the real string could be shorter */
3980             if (OP(scan) == EXACTFL) {
3981                 int total_chars = utf8_length((U8*) STRING(scan),
3982                                            (U8*) STRING(scan) + STR_LEN(scan));
3983                 if (total_count_delta > total_chars) {
3984                     total_count_delta = total_chars;
3985                 }
3986             }
3987
3988             *min_subtract += total_count_delta;
3989             Safefree(folded);
3990         }
3991         else if (OP(scan) == EXACTFA) {
3992
3993             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3994              * fold to the ASCII range (and there are no existing ones in the
3995              * upper latin1 range).  But, as outlined in the comments preceding
3996              * this function, we need to flag any occurrences of the sharp s.
3997              * This character forbids trie formation (because of added
3998              * complexity) */
3999 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4000    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4001                                       || UNICODE_DOT_DOT_VERSION > 0)
4002             while (s < s_end) {
4003                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4004                     OP(scan) = EXACTFA_NO_TRIE;
4005                     *unfolded_multi_char = TRUE;
4006                     break;
4007                 }
4008                 s++;
4009             }
4010         }
4011         else {
4012
4013             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
4014              * folds that are all Latin1.  As explained in the comments
4015              * preceding this function, we look also for the sharp s in EXACTF
4016              * and EXACTFL nodes; it can be in the final position.  Otherwise
4017              * we can stop looking 1 byte earlier because have to find at least
4018              * two characters for a multi-fold */
4019             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4020                               ? s_end
4021                               : s_end -1;
4022
4023             while (s < upper) {
4024                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4025                 if (! len) {    /* Not a multi-char fold. */
4026                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4027                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4028                     {
4029                         *unfolded_multi_char = TRUE;
4030                     }
4031                     s++;
4032                     continue;
4033                 }
4034
4035                 if (len == 2
4036                     && isALPHA_FOLD_EQ(*s, 's')
4037                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4038                 {
4039
4040                     /* EXACTF nodes need to know that the minimum length
4041                      * changed so that a sharp s in the string can match this
4042                      * ss in the pattern, but they remain EXACTF nodes, as they
4043                      * won't match this unless the target string is is UTF-8,
4044                      * which we don't know until runtime.  EXACTFL nodes can't
4045                      * transform into EXACTFU nodes */
4046                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4047                         OP(scan) = EXACTFU_SS;
4048                     }
4049                 }
4050
4051                 *min_subtract += len - 1;
4052                 s += len;
4053             }
4054 #endif
4055         }
4056     }
4057
4058 #ifdef DEBUGGING
4059     /* Allow dumping but overwriting the collection of skipped
4060      * ops and/or strings with fake optimized ops */
4061     n = scan + NODE_SZ_STR(scan);
4062     while (n <= stop) {
4063         OP(n) = OPTIMIZED;
4064         FLAGS(n) = 0;
4065         NEXT_OFF(n) = 0;
4066         n++;
4067     }
4068 #endif
4069     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
4070     return stopnow;
4071 }
4072
4073 /* REx optimizer.  Converts nodes into quicker variants "in place".
4074    Finds fixed substrings.  */
4075
4076 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4077    to the position after last scanned or to NULL. */
4078
4079 #define INIT_AND_WITHP \
4080     assert(!and_withp); \
4081     Newx(and_withp,1, regnode_ssc); \
4082     SAVEFREEPV(and_withp)
4083
4084
4085 static void
4086 S_unwind_scan_frames(pTHX_ const void *p)
4087 {
4088     scan_frame *f= (scan_frame *)p;
4089     do {
4090         scan_frame *n= f->next_frame;
4091         Safefree(f);
4092         f= n;
4093     } while (f);
4094 }
4095
4096
4097 STATIC SSize_t
4098 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4099                         SSize_t *minlenp, SSize_t *deltap,
4100                         regnode *last,
4101                         scan_data_t *data,
4102                         I32 stopparen,
4103                         U32 recursed_depth,
4104                         regnode_ssc *and_withp,
4105                         U32 flags, U32 depth)
4106                         /* scanp: Start here (read-write). */
4107                         /* deltap: Write maxlen-minlen here. */
4108                         /* last: Stop before this one. */
4109                         /* data: string data about the pattern */
4110                         /* stopparen: treat close N as END */
4111                         /* recursed: which subroutines have we recursed into */
4112                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4113 {
4114     /* There must be at least this number of characters to match */
4115     SSize_t min = 0;
4116     I32 pars = 0, code;
4117     regnode *scan = *scanp, *next;
4118     SSize_t delta = 0;
4119     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4120     int is_inf_internal = 0;            /* The studied chunk is infinite */
4121     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4122     scan_data_t data_fake;
4123     SV *re_trie_maxbuff = NULL;
4124     regnode *first_non_open = scan;
4125     SSize_t stopmin = SSize_t_MAX;
4126     scan_frame *frame = NULL;
4127     GET_RE_DEBUG_FLAGS_DECL;
4128
4129     PERL_ARGS_ASSERT_STUDY_CHUNK;
4130     RExC_study_started= 1;
4131
4132
4133     if ( depth == 0 ) {
4134         while (first_non_open && OP(first_non_open) == OPEN)
4135             first_non_open=regnext(first_non_open);
4136     }
4137
4138
4139   fake_study_recurse:
4140     DEBUG_r(
4141         RExC_study_chunk_recursed_count++;
4142     );
4143     DEBUG_OPTIMISE_MORE_r(
4144     {
4145         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4146             depth, (long)stopparen,
4147             (unsigned long)RExC_study_chunk_recursed_count,
4148             (unsigned long)depth, (unsigned long)recursed_depth,
4149             scan,
4150             last);
4151         if (recursed_depth) {
4152             U32 i;
4153             U32 j;
4154             for ( j = 0 ; j < recursed_depth ; j++ ) {
4155                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4156                     if (
4157                         PAREN_TEST(RExC_study_chunk_recursed +
4158                                    ( j * RExC_study_chunk_recursed_bytes), i )
4159                         && (
4160                             !j ||
4161                             !PAREN_TEST(RExC_study_chunk_recursed +
4162                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4163                         )
4164                     ) {
4165                         Perl_re_printf( aTHX_ " %d",(int)i);
4166                         break;
4167                     }
4168                 }
4169                 if ( j + 1 < recursed_depth ) {
4170                     Perl_re_printf( aTHX_  ",");
4171                 }
4172             }
4173         }
4174         Perl_re_printf( aTHX_ "\n");
4175     }
4176     );
4177     while ( scan && OP(scan) != END && scan < last ){
4178         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4179                                    node length to get a real minimum (because
4180                                    the folded version may be shorter) */
4181         bool unfolded_multi_char = FALSE;
4182         /* Peephole optimizer: */
4183         DEBUG_STUDYDATA("Peep:", data, depth);
4184         DEBUG_PEEP("Peep", scan, depth);
4185
4186
4187         /* The reason we do this here is that we need to deal with things like
4188          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4189          * parsing code, as each (?:..) is handled by a different invocation of
4190          * reg() -- Yves
4191          */
4192         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4193
4194         /* Follow the next-chain of the current node and optimize
4195            away all the NOTHINGs from it.  */
4196         if (OP(scan) != CURLYX) {
4197             const int max = (reg_off_by_arg[OP(scan)]
4198                        ? I32_MAX
4199                        /* I32 may be smaller than U16 on CRAYs! */
4200                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4201             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4202             int noff;
4203             regnode *n = scan;
4204
4205             /* Skip NOTHING and LONGJMP. */
4206             while ((n = regnext(n))
4207                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4208                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4209                    && off + noff < max)
4210                 off += noff;
4211             if (reg_off_by_arg[OP(scan)])
4212                 ARG(scan) = off;
4213             else
4214                 NEXT_OFF(scan) = off;
4215         }
4216
4217         /* The principal pseudo-switch.  Cannot be a switch, since we
4218            look into several different things.  */
4219         if ( OP(scan) == DEFINEP ) {
4220             SSize_t minlen = 0;
4221             SSize_t deltanext = 0;
4222             SSize_t fake_last_close = 0;
4223             I32 f = SCF_IN_DEFINE;
4224
4225             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4226             scan = regnext(scan);
4227             assert( OP(scan) == IFTHEN );
4228             DEBUG_PEEP("expect IFTHEN", scan, depth);
4229
4230             data_fake.last_closep= &fake_last_close;
4231             minlen = *minlenp;
4232             next = regnext(scan);
4233             scan = NEXTOPER(NEXTOPER(scan));
4234             DEBUG_PEEP("scan", scan, depth);
4235             DEBUG_PEEP("next", next, depth);
4236
4237             /* we suppose the run is continuous, last=next...
4238              * NOTE we dont use the return here! */
4239             (void)study_chunk(pRExC_state, &scan, &minlen,
4240                               &deltanext, next, &data_fake, stopparen,
4241                               recursed_depth, NULL, f, depth+1);
4242
4243             scan = next;
4244         } else
4245         if (
4246             OP(scan) == BRANCH  ||
4247             OP(scan) == BRANCHJ ||
4248             OP(scan) == IFTHEN
4249         ) {
4250             next = regnext(scan);
4251             code = OP(scan);
4252
4253             /* The op(next)==code check below is to see if we
4254              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4255              * IFTHEN is special as it might not appear in pairs.
4256              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4257              * we dont handle it cleanly. */
4258             if (OP(next) == code || code == IFTHEN) {
4259                 /* NOTE - There is similar code to this block below for
4260                  * handling TRIE nodes on a re-study.  If you change stuff here
4261                  * check there too. */
4262                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4263                 regnode_ssc accum;
4264                 regnode * const startbranch=scan;
4265
4266                 if (flags & SCF_DO_SUBSTR) {
4267                     /* Cannot merge strings after this. */
4268                     scan_commit(pRExC_state, data, minlenp, is_inf);
4269                 }
4270
4271                 if (flags & SCF_DO_STCLASS)
4272                     ssc_init_zero(pRExC_state, &accum);
4273
4274                 while (OP(scan) == code) {
4275                     SSize_t deltanext, minnext, fake;
4276                     I32 f = 0;
4277                     regnode_ssc this_class;
4278
4279                     DEBUG_PEEP("Branch", scan, depth);
4280
4281                     num++;
4282                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4283                     if (data) {
4284                         data_fake.whilem_c = data->whilem_c;
4285                         data_fake.last_closep = data->last_closep;
4286                     }
4287                     else
4288                         data_fake.last_closep = &fake;
4289
4290                     data_fake.pos_delta = delta;
4291                     next = regnext(scan);
4292
4293                     scan = NEXTOPER(scan); /* everything */
4294                     if (code != BRANCH)    /* everything but BRANCH */
4295                         scan = NEXTOPER(scan);
4296
4297                     if (flags & SCF_DO_STCLASS) {
4298                         ssc_init(pRExC_state, &this_class);
4299                         data_fake.start_class = &this_class;
4300                         f = SCF_DO_STCLASS_AND;
4301                     }
4302                     if (flags & SCF_WHILEM_VISITED_POS)
4303                         f |= SCF_WHILEM_VISITED_POS;
4304
4305                     /* we suppose the run is continuous, last=next...*/
4306                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4307                                       &deltanext, next, &data_fake, stopparen,
4308                                       recursed_depth, NULL, f,depth+1);
4309
4310                     if (min1 > minnext)
4311                         min1 = minnext;
4312                     if (deltanext == SSize_t_MAX) {
4313                         is_inf = is_inf_internal = 1;
4314                         max1 = SSize_t_MAX;
4315                     } else if (max1 < minnext + deltanext)
4316                         max1 = minnext + deltanext;
4317                     scan = next;
4318                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4319                         pars++;
4320                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4321                         if ( stopmin > minnext)
4322                             stopmin = min + min1;
4323                         flags &= ~SCF_DO_SUBSTR;
4324                         if (data)
4325                             data->flags |= SCF_SEEN_ACCEPT;
4326                     }
4327                     if (data) {
4328                         if (data_fake.flags & SF_HAS_EVAL)
4329                             data->flags |= SF_HAS_EVAL;
4330                         data->whilem_c = data_fake.whilem_c;
4331                     }
4332                     if (flags & SCF_DO_STCLASS)
4333                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4334                 }
4335                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4336                     min1 = 0;
4337                 if (flags & SCF_DO_SUBSTR) {
4338                     data->pos_min += min1;
4339                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4340                         data->pos_delta = SSize_t_MAX;
4341                     else
4342                         data->pos_delta += max1 - min1;
4343                     if (max1 != min1 || is_inf)
4344                         data->longest = &(data->longest_float);
4345                 }
4346                 min += min1;
4347                 if (delta == SSize_t_MAX
4348                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4349                     delta = SSize_t_MAX;
4350                 else
4351                     delta += max1 - min1;
4352                 if (flags & SCF_DO_STCLASS_OR) {
4353                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4354                     if (min1) {
4355                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4356                         flags &= ~SCF_DO_STCLASS;
4357                     }
4358                 }
4359                 else if (flags & SCF_DO_STCLASS_AND) {
4360                     if (min1) {
4361                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4362                         flags &= ~SCF_DO_STCLASS;
4363                     }
4364                     else {
4365                         /* Switch to OR mode: cache the old value of
4366                          * data->start_class */
4367                         INIT_AND_WITHP;
4368                         StructCopy(data->start_class, and_withp, regnode_ssc);
4369                         flags &= ~SCF_DO_STCLASS_AND;
4370                         StructCopy(&accum, data->start_class, regnode_ssc);
4371                         flags |= SCF_DO_STCLASS_OR;
4372                     }
4373                 }
4374
4375                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4376                         OP( startbranch ) == BRANCH )
4377                 {
4378                 /* demq.
4379
4380                    Assuming this was/is a branch we are dealing with: 'scan'
4381                    now points at the item that follows the branch sequence,
4382                    whatever it is. We now start at the beginning of the
4383                    sequence and look for subsequences of
4384
4385                    BRANCH->EXACT=>x1
4386                    BRANCH->EXACT=>x2
4387                    tail
4388
4389                    which would be constructed from a pattern like
4390                    /A|LIST|OF|WORDS/
4391
4392                    If we can find such a subsequence we need to turn the first
4393                    element into a trie and then add the subsequent branch exact
4394                    strings to the trie.
4395
4396                    We have two cases
4397
4398                      1. patterns where the whole set of branches can be
4399                         converted.
4400
4401                      2. patterns where only a subset can be converted.
4402
4403                    In case 1 we can replace the whole set with a single regop
4404                    for the trie. In case 2 we need to keep the start and end
4405                    branches so
4406
4407                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4408                      becomes BRANCH TRIE; BRANCH X;
4409
4410                   There is an additional case, that being where there is a
4411                   common prefix, which gets split out into an EXACT like node
4412                   preceding the TRIE node.
4413
4414                   If x(1..n)==tail then we can do a simple trie, if not we make
4415                   a "jump" trie, such that when we match the appropriate word
4416                   we "jump" to the appropriate tail node. Essentially we turn
4417                   a nested if into a case structure of sorts.
4418
4419                 */
4420
4421                     int made=0;
4422                     if (!re_trie_maxbuff) {
4423                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4424                         if (!SvIOK(re_trie_maxbuff))
4425                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4426                     }
4427                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4428                         regnode *cur;
4429                         regnode *first = (regnode *)NULL;
4430                         regnode *last = (regnode *)NULL;
4431                         regnode *tail = scan;
4432                         U8 trietype = 0;
4433                         U32 count=0;
4434
4435                         /* var tail is used because there may be a TAIL
4436                            regop in the way. Ie, the exacts will point to the
4437                            thing following the TAIL, but the last branch will
4438                            point at the TAIL. So we advance tail. If we
4439                            have nested (?:) we may have to move through several
4440                            tails.
4441                          */
4442
4443                         while ( OP( tail ) == TAIL ) {
4444                             /* this is the TAIL generated by (?:) */
4445                             tail = regnext( tail );
4446                         }
4447
4448
4449                         DEBUG_TRIE_COMPILE_r({
4450                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4451                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4452                               depth+1,
4453                               "Looking for TRIE'able sequences. Tail node is ",
4454                               (UV)(tail - RExC_emit_start),
4455                               SvPV_nolen_const( RExC_mysv )
4456                             );
4457                         });
4458
4459                         /*
4460
4461                             Step through the branches
4462                                 cur represents each branch,
4463                                 noper is the first thing to be matched as part
4464                                       of that branch
4465                                 noper_next is the regnext() of that node.
4466
4467                             We normally handle a case like this
4468                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4469                             support building with NOJUMPTRIE, which restricts
4470                             the trie logic to structures like /FOO|BAR/.
4471
4472                             If noper is a trieable nodetype then the branch is
4473                             a possible optimization target. If we are building
4474                             under NOJUMPTRIE then we require that noper_next is
4475                             the same as scan (our current position in the regex
4476                             program).
4477
4478                             Once we have two or more consecutive such branches
4479                             we can create a trie of the EXACT's contents and
4480                             stitch it in place into the program.
4481
4482                             If the sequence represents all of the branches in
4483                             the alternation we replace the entire thing with a
4484                             single TRIE node.
4485
4486                             Otherwise when it is a subsequence we need to
4487                             stitch it in place and replace only the relevant
4488                             branches. This means the first branch has to remain
4489                             as it is used by the alternation logic, and its
4490                             next pointer, and needs to be repointed at the item
4491                             on the branch chain following the last branch we
4492                             have optimized away.
4493
4494                             This could be either a BRANCH, in which case the
4495                             subsequence is internal, or it could be the item
4496                             following the branch sequence in which case the
4497                             subsequence is at the end (which does not
4498                             necessarily mean the first node is the start of the
4499                             alternation).
4500
4501                             TRIE_TYPE(X) is a define which maps the optype to a
4502                             trietype.
4503
4504                                 optype          |  trietype
4505                                 ----------------+-----------
4506                                 NOTHING         | NOTHING
4507                                 EXACT           | EXACT
4508                                 EXACTFU         | EXACTFU
4509                                 EXACTFU_SS      | EXACTFU
4510                                 EXACTFA         | EXACTFA
4511                                 EXACTL          | EXACTL
4512                                 EXACTFLU8       | EXACTFLU8
4513
4514
4515                         */
4516 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4517                        ? NOTHING                                            \
4518                        : ( EXACT == (X) )                                   \
4519                          ? EXACT                                            \
4520                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4521                            ? EXACTFU                                        \
4522                            : ( EXACTFA == (X) )                             \
4523                              ? EXACTFA                                      \
4524                              : ( EXACTL == (X) )                            \
4525                                ? EXACTL                                     \
4526                                : ( EXACTFLU8 == (X) )                        \
4527                                  ? EXACTFLU8                                 \
4528                                  : 0 )
4529
4530                         /* dont use tail as the end marker for this traverse */
4531                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4532                             regnode * const noper = NEXTOPER( cur );
4533                             U8 noper_type = OP( noper );
4534                             U8 noper_trietype = TRIE_TYPE( noper_type );
4535 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4536                             regnode * const noper_next = regnext( noper );
4537                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4538                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4539 #endif
4540
4541                             DEBUG_TRIE_COMPILE_r({
4542                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4543                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4544                                    depth+1,
4545                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4546
4547                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4548                                 Perl_re_printf( aTHX_  " -> %d:%s",
4549                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4550
4551                                 if ( noper_next ) {
4552                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4553                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4554                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4555                                 }
4556                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4557                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4558                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4559                                 );
4560                             });
4561
4562                             /* Is noper a trieable nodetype that can be merged
4563                              * with the current trie (if there is one)? */
4564                             if ( noper_trietype
4565                                   &&
4566                                   (
4567                                         ( noper_trietype == NOTHING )
4568                                         || ( trietype == NOTHING )
4569                                         || ( trietype == noper_trietype )
4570                                   )
4571 #ifdef NOJUMPTRIE
4572                                   && noper_next >= tail
4573 #endif
4574                                   && count < U16_MAX)
4575                             {
4576                                 /* Handle mergable triable node Either we are
4577                                  * the first node in a new trieable sequence,
4578                                  * in which case we do some bookkeeping,
4579                                  * otherwise we update the end pointer. */
4580                                 if ( !first ) {
4581                                     first = cur;
4582                                     if ( noper_trietype == NOTHING ) {
4583 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4584                                         regnode * const noper_next = regnext( noper );
4585                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4586                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4587 #endif
4588
4589                                         if ( noper_next_trietype ) {
4590                                             trietype = noper_next_trietype;
4591                                         } else if (noper_next_type)  {
4592                                             /* a NOTHING regop is 1 regop wide.
4593                                              * We need at least two for a trie
4594                                              * so we can't merge this in */
4595                                             first = NULL;
4596                                         }
4597                                     } else {
4598                                         trietype = noper_trietype;
4599                                     }
4600                                 } else {
4601                                     if ( trietype == NOTHING )
4602                                         trietype = noper_trietype;
4603                                     last = cur;
4604                                 }
4605                                 if (first)
4606                                     count++;
4607                             } /* end handle mergable triable node */
4608                             else {
4609                                 /* handle unmergable node -
4610                                  * noper may either be a triable node which can
4611                                  * not be tried together with the current trie,
4612                                  * or a non triable node */
4613                                 if ( last ) {
4614                                     /* If last is set and trietype is not
4615                                      * NOTHING then we have found at least two
4616                                      * triable branch sequences in a row of a
4617                                      * similar trietype so we can turn them
4618                                      * into a trie. If/when we allow NOTHING to
4619                                      * start a trie sequence this condition
4620                                      * will be required, and it isn't expensive
4621                                      * so we leave it in for now. */
4622                                     if ( trietype && trietype != NOTHING )
4623                                         make_trie( pRExC_state,
4624                                                 startbranch, first, cur, tail,
4625                                                 count, trietype, depth+1 );
4626                                     last = NULL; /* note: we clear/update
4627                                                     first, trietype etc below,
4628                                                     so we dont do it here */
4629                                 }
4630                                 if ( noper_trietype
4631 #ifdef NOJUMPTRIE
4632                                      && noper_next >= tail
4633 #endif
4634                                 ){
4635                                     /* noper is triable, so we can start a new
4636                                      * trie sequence */
4637                                     count = 1;
4638                                     first = cur;
4639                                     trietype = noper_trietype;
4640                                 } else if (first) {
4641                                     /* if we already saw a first but the
4642                                      * current node is not triable then we have
4643                                      * to reset the first information. */
4644                                     count = 0;
4645                                     first = NULL;
4646                                     trietype = 0;
4647                                 }
4648                             } /* end handle unmergable node */
4649                         } /* loop over branches */
4650                         DEBUG_TRIE_COMPILE_r({
4651                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4652                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4653                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4654                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4655                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4656                                PL_reg_name[trietype]
4657                             );
4658
4659                         });
4660                         if ( last && trietype ) {
4661                             if ( trietype != NOTHING ) {
4662                                 /* the last branch of the sequence was part of
4663                                  * a trie, so we have to construct it here
4664                                  * outside of the loop */
4665                                 made= make_trie( pRExC_state, startbranch,
4666                                                  first, scan, tail, count,
4667                                                  trietype, depth+1 );
4668 #ifdef TRIE_STUDY_OPT
4669                                 if ( ((made == MADE_EXACT_TRIE &&
4670                                      startbranch == first)
4671                                      || ( first_non_open == first )) &&
4672                                      depth==0 ) {
4673                                     flags |= SCF_TRIE_RESTUDY;
4674                                     if ( startbranch == first
4675                                          && scan >= tail )
4676                                     {
4677                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4678                                     }
4679                                 }
4680 #endif
4681                             } else {
4682                                 /* at this point we know whatever we have is a
4683                                  * NOTHING sequence/branch AND if 'startbranch'
4684                                  * is 'first' then we can turn the whole thing
4685                                  * into a NOTHING
4686                                  */
4687                                 if ( startbranch == first ) {
4688                                     regnode *opt;
4689                                     /* the entire thing is a NOTHING sequence,
4690                                      * something like this: (?:|) So we can
4691                                      * turn it into a plain NOTHING op. */
4692                                     DEBUG_TRIE_COMPILE_r({
4693                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4694                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4695                                           depth+1,
4696                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4697
4698                                     });
4699                                     OP(startbranch)= NOTHING;
4700                                     NEXT_OFF(startbranch)= tail - startbranch;
4701                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4702                                         OP(opt)= OPTIMIZED;
4703                                 }
4704                             }
4705                         } /* end if ( last) */
4706                     } /* TRIE_MAXBUF is non zero */
4707
4708                 } /* do trie */
4709
4710             }
4711             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4712                 scan = NEXTOPER(NEXTOPER(scan));
4713             } else                      /* single branch is optimized. */
4714                 scan = NEXTOPER(scan);
4715             continue;
4716         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4717             I32 paren = 0;
4718             regnode *start = NULL;
4719             regnode *end = NULL;
4720             U32 my_recursed_depth= recursed_depth;
4721
4722             if (OP(scan) != SUSPEND) { /* GOSUB */
4723                 /* Do setup, note this code has side effects beyond
4724                  * the rest of this block. Specifically setting
4725                  * RExC_recurse[] must happen at least once during
4726                  * study_chunk(). */
4727                 paren = ARG(scan);
4728                 RExC_recurse[ARG2L(scan)] = scan;
4729                 start = RExC_open_parens[paren];
4730                 end   = RExC_close_parens[paren];
4731
4732                 /* NOTE we MUST always execute the above code, even
4733                  * if we do nothing with a GOSUB */
4734                 if (
4735                     ( flags & SCF_IN_DEFINE )
4736                     ||
4737                     (
4738                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4739                         &&
4740                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4741                     )
4742                 ) {
4743                     /* no need to do anything here if we are in a define. */
4744                     /* or we are after some kind of infinite construct
4745                      * so we can skip recursing into this item.
4746                      * Since it is infinite we will not change the maxlen
4747                      * or delta, and if we miss something that might raise
4748                      * the minlen it will merely pessimise a little.
4749                      *
4750                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4751                      * might result in a minlen of 1 and not of 4,
4752                      * but this doesn't make us mismatch, just try a bit
4753                      * harder than we should.
4754                      * */
4755                     scan= regnext(scan);
4756                     continue;
4757                 }
4758
4759                 if (
4760                     !recursed_depth
4761                     ||
4762                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4763                 ) {
4764                     /* it is quite possible that there are more efficient ways
4765                      * to do this. We maintain a bitmap per level of recursion
4766                      * of which patterns we have entered so we can detect if a
4767                      * pattern creates a possible infinite loop. When we
4768                      * recurse down a level we copy the previous levels bitmap
4769                      * down. When we are at recursion level 0 we zero the top
4770                      * level bitmap. It would be nice to implement a different
4771                      * more efficient way of doing this. In particular the top
4772                      * level bitmap may be unnecessary.
4773                      */
4774                     if (!recursed_depth) {
4775                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4776                     } else {
4777                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4778                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4779                              RExC_study_chunk_recursed_bytes, U8);
4780                     }
4781                     /* we havent recursed into this paren yet, so recurse into it */
4782                     DEBUG_STUDYDATA("gosub-set:", data,depth);
4783                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4784                     my_recursed_depth= recursed_depth + 1;
4785                 } else {
4786                     DEBUG_STUDYDATA("gosub-inf:", data,depth);
4787                     /* some form of infinite recursion, assume infinite length
4788                      * */
4789                     if (flags & SCF_DO_SUBSTR) {
4790                         scan_commit(pRExC_state, data, minlenp, is_inf);
4791                         data->longest = &(data->longest_float);
4792                     }
4793                     is_inf = is_inf_internal = 1;
4794                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4795                         ssc_anything(data->start_class);
4796                     flags &= ~SCF_DO_STCLASS;
4797
4798                     start= NULL; /* reset start so we dont recurse later on. */
4799                 }
4800             } else {
4801                 paren = stopparen;
4802                 start = scan + 2;
4803                 end = regnext(scan);
4804             }
4805             if (start) {
4806                 scan_frame *newframe;
4807                 assert(end);
4808                 if (!RExC_frame_last) {
4809                     Newxz(newframe, 1, scan_frame);
4810                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4811                     RExC_frame_head= newframe;
4812                     RExC_frame_count++;
4813                 } else if (!RExC_frame_last->next_frame) {
4814                     Newxz(newframe,1,scan_frame);
4815                     RExC_frame_last->next_frame= newframe;
4816                     newframe->prev_frame= RExC_frame_last;
4817                     RExC_frame_count++;
4818                 } else {
4819                     newframe= RExC_frame_last->next_frame;
4820                 }
4821                 RExC_frame_last= newframe;
4822
4823                 newframe->next_regnode = regnext(scan);
4824                 newframe->last_regnode = last;
4825                 newframe->stopparen = stopparen;
4826                 newframe->prev_recursed_depth = recursed_depth;
4827                 newframe->this_prev_frame= frame;
4828
4829                 DEBUG_STUDYDATA("frame-new:",data,depth);
4830                 DEBUG_PEEP("fnew", scan, depth);
4831
4832                 frame = newframe;
4833                 scan =  start;
4834                 stopparen = paren;
4835                 last = end;
4836                 depth = depth + 1;
4837                 recursed_depth= my_recursed_depth;
4838
4839                 continue;
4840             }
4841         }
4842         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4843             SSize_t l = STR_LEN(scan);
4844             UV uc;
4845             if (UTF) {
4846                 const U8 * const s = (U8*)STRING(scan);
4847                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4848                 l = utf8_length(s, s + l);
4849             } else {
4850                 uc = *((U8*)STRING(scan));
4851             }
4852             min += l;
4853             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4854                 /* The code below prefers earlier match for fixed
4855                    offset, later match for variable offset.  */
4856                 if (data->last_end == -1) { /* Update the start info. */
4857                     data->last_start_min = data->pos_min;
4858                     data->last_start_max = is_inf
4859                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4860                 }
4861                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4862                 if (UTF)
4863                     SvUTF8_on(data->last_found);
4864                 {
4865                     SV * const sv = data->last_found;
4866                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4867                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4868                     if (mg && mg->mg_len >= 0)
4869                         mg->mg_len += utf8_length((U8*)STRING(scan),
4870                                               (U8*)STRING(scan)+STR_LEN(scan));
4871                 }
4872                 data->last_end = data->pos_min + l;
4873                 data->pos_min += l; /* As in the first entry. */
4874                 data->flags &= ~SF_BEFORE_EOL;
4875             }
4876
4877             /* ANDing the code point leaves at most it, and not in locale, and
4878              * can't match null string */
4879             if (flags & SCF_DO_STCLASS_AND) {
4880                 ssc_cp_and(data->start_class, uc);
4881                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4882                 ssc_clear_locale(data->start_class);
4883             }
4884             else if (flags & SCF_DO_STCLASS_OR) {
4885                 ssc_add_cp(data->start_class, uc);
4886                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4887
4888                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4889                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4890             }
4891             flags &= ~SCF_DO_STCLASS;
4892         }
4893         else if (PL_regkind[OP(scan)] == EXACT) {
4894             /* But OP != EXACT!, so is EXACTFish */
4895             SSize_t l = STR_LEN(scan);
4896             const U8 * s = (U8*)STRING(scan);
4897
4898             /* Search for fixed substrings supports EXACT only. */
4899             if (flags & SCF_DO_SUBSTR) {
4900                 assert(data);
4901                 scan_commit(pRExC_state, data, minlenp, is_inf);
4902             }
4903             if (UTF) {
4904                 l = utf8_length(s, s + l);
4905             }
4906             if (unfolded_multi_char) {
4907                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4908             }
4909             min += l - min_subtract;
4910             assert (min >= 0);
4911             delta += min_subtract;
4912             if (flags & SCF_DO_SUBSTR) {
4913                 data->pos_min += l - min_subtract;
4914                 if (data->pos_min < 0) {
4915                     data->pos_min = 0;
4916                 }
4917                 data->pos_delta += min_subtract;
4918                 if (min_subtract) {
4919                     data->longest = &(data->longest_float);
4920                 }
4921             }
4922
4923             if (flags & SCF_DO_STCLASS) {
4924                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4925
4926                 assert(EXACTF_invlist);
4927                 if (flags & SCF_DO_STCLASS_AND) {
4928                     if (OP(scan) != EXACTFL)
4929                         ssc_clear_locale(data->start_class);
4930                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4931                     ANYOF_POSIXL_ZERO(data->start_class);
4932                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4933                 }
4934                 else {  /* SCF_DO_STCLASS_OR */
4935                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4936                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4937
4938                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4939                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4940                 }
4941                 flags &= ~SCF_DO_STCLASS;
4942                 SvREFCNT_dec(EXACTF_invlist);
4943             }
4944         }
4945         else if (REGNODE_VARIES(OP(scan))) {
4946             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4947             I32 fl = 0, f = flags;
4948             regnode * const oscan = scan;
4949             regnode_ssc this_class;
4950             regnode_ssc *oclass = NULL;
4951             I32 next_is_eval = 0;
4952
4953             switch (PL_regkind[OP(scan)]) {
4954             case WHILEM:                /* End of (?:...)* . */
4955                 scan = NEXTOPER(scan);
4956                 goto finish;
4957             case PLUS:
4958                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4959                     next = NEXTOPER(scan);
4960                     if (OP(next) == EXACT
4961                         || OP(next) == EXACTL
4962                         || (flags & SCF_DO_STCLASS))
4963                     {
4964                         mincount = 1;
4965                         maxcount = REG_INFTY;
4966                         next = regnext(scan);
4967                         scan = NEXTOPER(scan);
4968                         goto do_curly;
4969                     }
4970                 }
4971                 if (flags & SCF_DO_SUBSTR)
4972                     data->pos_min++;
4973                 min++;
4974                 /* FALLTHROUGH */
4975             case STAR:
4976                 if (flags & SCF_DO_STCLASS) {
4977                     mincount = 0;
4978                     maxcount = REG_INFTY;
4979                     next = regnext(scan);
4980                     scan = NEXTOPER(scan);
4981                     goto do_curly;
4982                 }
4983                 if (flags & SCF_DO_SUBSTR) {
4984                     scan_commit(pRExC_state, data, minlenp, is_inf);
4985                     /* Cannot extend fixed substrings */
4986                     data->longest = &(data->longest_float);
4987                 }
4988                 is_inf = is_inf_internal = 1;
4989                 scan = regnext(scan);
4990                 goto optimize_curly_tail;
4991             case CURLY:
4992                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4993                     && (scan->flags == stopparen))
4994                 {
4995                     mincount = 1;
4996                     maxcount = 1;
4997                 } else {
4998                     mincount = ARG1(scan);
4999                     maxcount = ARG2(scan);
5000                 }
5001                 next = regnext(scan);
5002                 if (OP(scan) == CURLYX) {
5003                     I32 lp = (data ? *(data->last_closep) : 0);
5004                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5005                 }
5006                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5007                 next_is_eval = (OP(scan) == EVAL);
5008               do_curly:
5009                 if (flags & SCF_DO_SUBSTR) {
5010                     if (mincount == 0)
5011                         scan_commit(pRExC_state, data, minlenp, is_inf);
5012                     /* Cannot extend fixed substrings */
5013                     pos_before = data->pos_min;
5014                 }
5015                 if (data) {
5016                     fl = data->flags;
5017                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5018                     if (is_inf)
5019                         data->flags |= SF_IS_INF;
5020                 }
5021                 if (flags & SCF_DO_STCLASS) {
5022                     ssc_init(pRExC_state, &this_class);
5023                     oclass = data->start_class;
5024                     data->start_class = &this_class;
5025                     f |= SCF_DO_STCLASS_AND;
5026                     f &= ~SCF_DO_STCLASS_OR;
5027                 }
5028                 /* Exclude from super-linear cache processing any {n,m}
5029                    regops for which the combination of input pos and regex
5030                    pos is not enough information to determine if a match
5031                    will be possible.
5032
5033                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5034                    regex pos at the \s*, the prospects for a match depend not
5035                    only on the input position but also on how many (bar\s*)
5036                    repeats into the {4,8} we are. */
5037                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5038                     f &= ~SCF_WHILEM_VISITED_POS;
5039
5040                 /* This will finish on WHILEM, setting scan, or on NULL: */
5041                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5042                                   last, data, stopparen, recursed_depth, NULL,
5043                                   (mincount == 0
5044                                    ? (f & ~SCF_DO_SUBSTR)
5045                                    : f)
5046                                   ,depth+1);
5047
5048                 if (flags & SCF_DO_STCLASS)
5049                     data->start_class = oclass;
5050                 if (mincount == 0 || minnext == 0) {
5051                     if (flags & SCF_DO_STCLASS_OR) {
5052                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5053                     }
5054                     else if (flags & SCF_DO_STCLASS_AND) {
5055                         /* Switch to OR mode: cache the old value of
5056                          * data->start_class */
5057                         INIT_AND_WITHP;
5058                         StructCopy(data->start_class, and_withp, regnode_ssc);
5059                         flags &= ~SCF_DO_STCLASS_AND;
5060                         StructCopy(&this_class, data->start_class, regnode_ssc);
5061                         flags |= SCF_DO_STCLASS_OR;
5062                         ANYOF_FLAGS(data->start_class)
5063                                                 |= SSC_MATCHES_EMPTY_STRING;
5064                     }
5065                 } else {                /* Non-zero len */
5066                     if (flags & SCF_DO_STCLASS_OR) {
5067                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5068                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5069                     }
5070                     else if (flags & SCF_DO_STCLASS_AND)
5071                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5072                     flags &= ~SCF_DO_STCLASS;
5073                 }
5074                 if (!scan)              /* It was not CURLYX, but CURLY. */
5075                     scan = next;
5076                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
5077                     /* ? quantifier ok, except for (?{ ... }) */
5078                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5079                     && (minnext == 0) && (deltanext == 0)
5080                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5081                     && maxcount <= REG_INFTY/3) /* Complement check for big
5082                                                    count */
5083                 {
5084                     /* Fatal warnings may leak the regexp without this: */
5085                     SAVEFREESV(RExC_rx_sv);
5086                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5087                         "Quantifier unexpected on zero-length expression "
5088                         "in regex m/%" UTF8f "/",
5089                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5090                                   RExC_precomp));
5091                     (void)ReREFCNT_inc(RExC_rx_sv);
5092                 }
5093
5094                 min += minnext * mincount;
5095                 is_inf_internal |= deltanext == SSize_t_MAX
5096                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5097                 is_inf |= is_inf_internal;
5098                 if (is_inf) {
5099                     delta = SSize_t_MAX;
5100                 } else {
5101                     delta += (minnext + deltanext) * maxcount
5102                              - minnext * mincount;
5103                 }
5104                 /* Try powerful optimization CURLYX => CURLYN. */
5105                 if (  OP(oscan) == CURLYX && data
5106                       && data->flags & SF_IN_PAR
5107                       && !(data->flags & SF_HAS_EVAL)
5108                       && !deltanext && minnext == 1 ) {
5109                     /* Try to optimize to CURLYN.  */
5110                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5111                     regnode * const nxt1 = nxt;
5112 #ifdef DEBUGGING
5113                     regnode *nxt2;
5114 #endif
5115
5116                     /* Skip open. */
5117                     nxt = regnext(nxt);
5118                     if (!REGNODE_SIMPLE(OP(nxt))
5119                         && !(PL_regkind[OP(nxt)] == EXACT
5120                              && STR_LEN(nxt) == 1))
5121                         goto nogo;
5122 #ifdef DEBUGGING
5123                     nxt2 = nxt;
5124 #endif
5125                     nxt = regnext(nxt);
5126                     if (OP(nxt) != CLOSE)
5127                         goto nogo;
5128                     if (RExC_open_parens) {
5129                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5130                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5131                     }
5132                     /* Now we know that nxt2 is the only contents: */
5133                     oscan->flags = (U8)ARG(nxt);
5134                     OP(oscan) = CURLYN;
5135                     OP(nxt1) = NOTHING; /* was OPEN. */
5136
5137 #ifdef DEBUGGING
5138                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5139                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5140                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5141                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5142                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5143                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5144 #endif
5145                 }
5146               nogo:
5147
5148                 /* Try optimization CURLYX => CURLYM. */
5149                 if (  OP(oscan) == CURLYX && data
5150                       && !(data->flags & SF_HAS_PAR)
5151                       && !(data->flags & SF_HAS_EVAL)
5152                       && !deltanext     /* atom is fixed width */
5153                       && minnext != 0   /* CURLYM can't handle zero width */
5154
5155                          /* Nor characters whose fold at run-time may be
5156                           * multi-character */
5157                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5158                 ) {
5159                     /* XXXX How to optimize if data == 0? */
5160                     /* Optimize to a simpler form.  */
5161                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5162                     regnode *nxt2;
5163
5164                     OP(oscan) = CURLYM;
5165                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5166                             && (OP(nxt2) != WHILEM))
5167                         nxt = nxt2;
5168                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5169                     /* Need to optimize away parenths. */
5170                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5171                         /* Set the parenth number.  */
5172                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5173
5174                         oscan->flags = (U8)ARG(nxt);
5175                         if (RExC_open_parens) {
5176                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5177                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5178                         }
5179                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5180                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5181
5182 #ifdef DEBUGGING
5183                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5184                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5185                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5186                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5187 #endif
5188 #if 0
5189                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5190                             regnode *nnxt = regnext(nxt1);
5191                             if (nnxt == nxt) {
5192                                 if (reg_off_by_arg[OP(nxt1)])
5193                                     ARG_SET(nxt1, nxt2 - nxt1);
5194                                 else if (nxt2 - nxt1 < U16_MAX)
5195                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5196                                 else
5197                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5198                             }
5199                             nxt1 = nnxt;
5200                         }
5201 #endif
5202                         /* Optimize again: */
5203                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5204                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5205                     }
5206                     else
5207                         oscan->flags = 0;
5208                 }
5209                 else if ((OP(oscan) == CURLYX)
5210                          && (flags & SCF_WHILEM_VISITED_POS)
5211                          /* See the comment on a similar expression above.
5212                             However, this time it's not a subexpression
5213                             we care about, but the expression itself. */
5214                          && (maxcount == REG_INFTY)
5215                          && data) {
5216                     /* This stays as CURLYX, we can put the count/of pair. */
5217                     /* Find WHILEM (as in regexec.c) */
5218                     regnode *nxt = oscan + NEXT_OFF(oscan);
5219
5220                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5221                         nxt += ARG(nxt);
5222                     nxt = PREVOPER(nxt);
5223                     if (nxt->flags & 0xf) {
5224                         /* we've already set whilem count on this node */
5225                     } else if (++data->whilem_c < 16) {
5226                         assert(data->whilem_c <= RExC_whilem_seen);
5227                         nxt->flags = (U8)(data->whilem_c
5228                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5229                     }
5230                 }
5231                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5232                     pars++;
5233                 if (flags & SCF_DO_SUBSTR) {
5234                     SV *last_str = NULL;
5235                     STRLEN last_chrs = 0;
5236                     int counted = mincount != 0;
5237
5238                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5239                                                                   string. */
5240                         SSize_t b = pos_before >= data->last_start_min
5241                             ? pos_before : data->last_start_min;
5242                         STRLEN l;
5243                         const char * const s = SvPV_const(data->last_found, l);
5244                         SSize_t old = b - data->last_start_min;
5245
5246                         if (UTF)
5247                             old = utf8_hop((U8*)s, old) - (U8*)s;
5248                         l -= old;
5249                         /* Get the added string: */
5250                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5251                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5252                                             (U8*)(s + old + l)) : l;
5253                         if (deltanext == 0 && pos_before == b) {
5254                             /* What was added is a constant string */
5255                             if (mincount > 1) {
5256
5257                                 SvGROW(last_str, (mincount * l) + 1);
5258                                 repeatcpy(SvPVX(last_str) + l,
5259                                           SvPVX_const(last_str), l,
5260                                           mincount - 1);
5261                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5262                                 /* Add additional parts. */
5263                                 SvCUR_set(data->last_found,
5264                                           SvCUR(data->last_found) - l);
5265                                 sv_catsv(data->last_found, last_str);
5266                                 {
5267                                     SV * sv = data->last_found;
5268                                     MAGIC *mg =
5269                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5270                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5271                                     if (mg && mg->mg_len >= 0)
5272                                         mg->mg_len += last_chrs * (mincount-1);
5273                                 }
5274                                 last_chrs *= mincount;
5275                                 data->last_end += l * (mincount - 1);
5276                             }
5277                         } else {
5278                             /* start offset must point into the last copy */
5279                             data->last_start_min += minnext * (mincount - 1);
5280                             data->last_start_max =
5281                               is_inf
5282                                ? SSize_t_MAX
5283                                : data->last_start_max +
5284                                  (maxcount - 1) * (minnext + data->pos_delta);
5285                         }
5286                     }
5287                     /* It is counted once already... */
5288                     data->pos_min += minnext * (mincount - counted);
5289 #if 0
5290 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5291                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5292                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5293     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5294     (UV)mincount);
5295 if (deltanext != SSize_t_MAX)
5296 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5297     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5298           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5299 #endif
5300                     if (deltanext == SSize_t_MAX
5301                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5302                         data->pos_delta = SSize_t_MAX;
5303                     else
5304                         data->pos_delta += - counted * deltanext +
5305                         (minnext + deltanext) * maxcount - minnext * mincount;
5306                     if (mincount != maxcount) {
5307                          /* Cannot extend fixed substrings found inside
5308                             the group.  */
5309                         scan_commit(pRExC_state, data, minlenp, is_inf);
5310                         if (mincount && last_str) {
5311                             SV * const sv = data->last_found;
5312                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5313                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5314
5315                             if (mg)
5316                                 mg->mg_len = -1;
5317                             sv_setsv(sv, last_str);
5318                             data->last_end = data->pos_min;
5319                             data->last_start_min = data->pos_min - last_chrs;
5320                             data->last_start_max = is_inf
5321                                 ? SSize_t_MAX
5322                                 : data->pos_min + data->pos_delta - last_chrs;
5323                         }
5324                         data->longest = &(data->longest_float);
5325                     }
5326                     SvREFCNT_dec(last_str);
5327                 }
5328                 if (data && (fl & SF_HAS_EVAL))
5329                     data->flags |= SF_HAS_EVAL;
5330               optimize_curly_tail:
5331                 if (OP(oscan) != CURLYX) {
5332                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5333                            && NEXT_OFF(next))
5334                         NEXT_OFF(oscan) += NEXT_OFF(next);
5335                 }
5336                 continue;
5337
5338             default:
5339 #ifdef DEBUGGING
5340                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5341                                                                     OP(scan));
5342 #endif
5343             case REF:
5344             case CLUMP:
5345                 if (flags & SCF_DO_SUBSTR) {
5346                     /* Cannot expect anything... */
5347                     scan_commit(pRExC_state, data, minlenp, is_inf);
5348                     data->longest = &(data->longest_float);
5349                 }
5350                 is_inf = is_inf_internal = 1;
5351                 if (flags & SCF_DO_STCLASS_OR) {
5352                     if (OP(scan) == CLUMP) {
5353                         /* Actually is any start char, but very few code points
5354                          * aren't start characters */
5355                         ssc_match_all_cp(data->start_class);
5356                     }
5357                     else {
5358                         ssc_anything(data->start_class);
5359                     }
5360                 }
5361                 flags &= ~SCF_DO_STCLASS;
5362                 break;
5363             }
5364         }
5365         else if (OP(scan) == LNBREAK) {
5366             if (flags & SCF_DO_STCLASS) {
5367                 if (flags & SCF_DO_STCLASS_AND) {
5368                     ssc_intersection(data->start_class,
5369                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5370                     ssc_clear_locale(data->start_class);
5371                     ANYOF_FLAGS(data->start_class)
5372                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5373                 }
5374                 else if (flags & SCF_DO_STCLASS_OR) {
5375                     ssc_union(data->start_class,
5376                               PL_XPosix_ptrs[_CC_VERTSPACE],
5377                               FALSE);
5378                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5379
5380                     /* See commit msg for
5381                      * 749e076fceedeb708a624933726e7989f2302f6a */
5382                     ANYOF_FLAGS(data->start_class)
5383                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5384                 }
5385                 flags &= ~SCF_DO_STCLASS;
5386             }
5387             min++;
5388             if (delta != SSize_t_MAX)
5389                 delta++;    /* Because of the 2 char string cr-lf */
5390             if (flags & SCF_DO_SUBSTR) {
5391                 /* Cannot expect anything... */
5392                 scan_commit(pRExC_state, data, minlenp, is_inf);
5393                 data->pos_min += 1;
5394                 data->pos_delta += 1;
5395                 data->longest = &(data->longest_float);
5396             }
5397         }
5398         else if (REGNODE_SIMPLE(OP(scan))) {
5399
5400             if (flags & SCF_DO_SUBSTR) {
5401                 scan_commit(pRExC_state, data, minlenp, is_inf);
5402                 data->pos_min++;
5403             }
5404             min++;
5405             if (flags & SCF_DO_STCLASS) {
5406                 bool invert = 0;
5407                 SV* my_invlist = NULL;
5408                 U8 namedclass;
5409
5410                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5411                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5412
5413                 /* Some of the logic below assumes that switching
5414                    locale on will only add false positives. */
5415                 switch (OP(scan)) {
5416
5417                 default:
5418 #ifdef DEBUGGING
5419                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5420                                                                      OP(scan));
5421 #endif
5422                 case SANY:
5423                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5424                         ssc_match_all_cp(data->start_class);
5425                     break;
5426
5427                 case REG_ANY:
5428                     {
5429                         SV* REG_ANY_invlist = _new_invlist(2);
5430                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5431                                                             '\n');
5432                         if (flags & SCF_DO_STCLASS_OR) {
5433                             ssc_union(data->start_class,
5434                                       REG_ANY_invlist,
5435                                       TRUE /* TRUE => invert, hence all but \n
5436                                             */
5437                                       );
5438                         }
5439                         else if (flags & SCF_DO_STCLASS_AND) {
5440                             ssc_intersection(data->start_class,
5441                                              REG_ANY_invlist,
5442                                              TRUE  /* TRUE => invert */
5443                                              );
5444                             ssc_clear_locale(data->start_class);
5445                         }
5446                         SvREFCNT_dec_NN(REG_ANY_invlist);
5447                     }
5448                     break;
5449
5450                 case ANYOFD:
5451                 case ANYOFL:
5452                 case ANYOF:
5453                     if (flags & SCF_DO_STCLASS_AND)
5454                         ssc_and(pRExC_state, data->start_class,
5455                                 (regnode_charclass *) scan);
5456                     else
5457                         ssc_or(pRExC_state, data->start_class,
5458                                                           (regnode_charclass *) scan);
5459                     break;
5460
5461                 case NPOSIXL:
5462                     invert = 1;
5463                     /* FALLTHROUGH */
5464
5465                 case POSIXL:
5466                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5467                     if (flags & SCF_DO_STCLASS_AND) {
5468                         bool was_there = cBOOL(
5469                                           ANYOF_POSIXL_TEST(data->start_class,
5470                                                                  namedclass));
5471                         ANYOF_POSIXL_ZERO(data->start_class);
5472                         if (was_there) {    /* Do an AND */
5473                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5474                         }
5475                         /* No individual code points can now match */
5476                         data->start_class->invlist
5477                                                 = sv_2mortal(_new_invlist(0));
5478                     }
5479                     else {
5480                         int complement = namedclass + ((invert) ? -1 : 1);
5481
5482                         assert(flags & SCF_DO_STCLASS_OR);
5483
5484                         /* If the complement of this class was already there,
5485                          * the result is that they match all code points,
5486                          * (\d + \D == everything).  Remove the classes from
5487                          * future consideration.  Locale is not relevant in
5488                          * this case */
5489                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5490                             ssc_match_all_cp(data->start_class);
5491                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5492                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5493                         }
5494                         else {  /* The usual case; just add this class to the
5495                                    existing set */
5496                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5497                         }
5498                     }
5499                     break;
5500
5501                 case NPOSIXA:   /* For these, we always know the exact set of
5502                                    what's matched */
5503                     invert = 1;
5504                     /* FALLTHROUGH */
5505                 case POSIXA:
5506                     if (FLAGS(scan) == _CC_ASCII) {
5507                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5508                     }
5509                     else {
5510                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5511                                               PL_XPosix_ptrs[_CC_ASCII],
5512                                               &my_invlist);
5513                     }
5514                     goto join_posix;
5515
5516                 case NPOSIXD:
5517                 case NPOSIXU:
5518                     invert = 1;
5519                     /* FALLTHROUGH */
5520                 case POSIXD:
5521                 case POSIXU:
5522                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5523
5524                     /* NPOSIXD matches all upper Latin1 code points unless the
5525                      * target string being matched is UTF-8, which is
5526                      * unknowable until match time.  Since we are going to
5527                      * invert, we want to get rid of all of them so that the
5528                      * inversion will match all */
5529                     if (OP(scan) == NPOSIXD) {
5530                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5531                                           &my_invlist);
5532                     }
5533
5534                   join_posix:
5535
5536                     if (flags & SCF_DO_STCLASS_AND) {
5537                         ssc_intersection(data->start_class, my_invlist, invert);
5538                         ssc_clear_locale(data->start_class);
5539                     }
5540                     else {
5541                         assert(flags & SCF_DO_STCLASS_OR);
5542                         ssc_union(data->start_class, my_invlist, invert);
5543                     }
5544                     SvREFCNT_dec(my_invlist);
5545                 }
5546                 if (flags & SCF_DO_STCLASS_OR)
5547                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5548                 flags &= ~SCF_DO_STCLASS;
5549             }
5550         }
5551         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5552             data->flags |= (OP(scan) == MEOL
5553                             ? SF_BEFORE_MEOL
5554                             : SF_BEFORE_SEOL);
5555             scan_commit(pRExC_state, data, minlenp, is_inf);
5556
5557         }
5558         else if (  PL_regkind[OP(scan)] == BRANCHJ
5559                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5560                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5561                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5562         {
5563             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5564                 || OP(scan) == UNLESSM )
5565             {
5566                 /* Negative Lookahead/lookbehind
5567                    In this case we can't do fixed string optimisation.
5568                 */
5569
5570                 SSize_t deltanext, minnext, fake = 0;
5571                 regnode *nscan;
5572                 regnode_ssc intrnl;
5573                 int f = 0;
5574
5575                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5576                 if (data) {
5577                     data_fake.whilem_c = data->whilem_c;
5578                     data_fake.last_closep = data->last_closep;
5579                 }
5580                 else
5581                     data_fake.last_closep = &fake;
5582                 data_fake.pos_delta = delta;
5583                 if ( flags & SCF_DO_STCLASS && !scan->flags
5584                      && OP(scan) == IFMATCH ) { /* Lookahead */
5585                     ssc_init(pRExC_state, &intrnl);
5586                     data_fake.start_class = &intrnl;
5587                     f |= SCF_DO_STCLASS_AND;
5588                 }
5589                 if (flags & SCF_WHILEM_VISITED_POS)
5590                     f |= SCF_WHILEM_VISITED_POS;
5591                 next = regnext(scan);
5592                 nscan = NEXTOPER(NEXTOPER(scan));
5593                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5594                                       last, &data_fake, stopparen,
5595                                       recursed_depth, NULL, f, depth+1);
5596                 if (scan->flags) {
5597                     if (deltanext) {
5598                         FAIL("Variable length lookbehind not implemented");
5599                     }
5600                     else if (minnext > (I32)U8_MAX) {
5601                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5602                               (UV)U8_MAX);
5603                     }
5604                     scan->flags = (U8)minnext;
5605                 }
5606                 if (data) {
5607                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5608                         pars++;
5609                     if (data_fake.flags & SF_HAS_EVAL)
5610                         data->flags |= SF_HAS_EVAL;
5611                     data->whilem_c = data_fake.whilem_c;
5612                 }
5613                 if (f & SCF_DO_STCLASS_AND) {
5614                     if (flags & SCF_DO_STCLASS_OR) {
5615                         /* OR before, AND after: ideally we would recurse with
5616                          * data_fake to get the AND applied by study of the
5617                          * remainder of the pattern, and then derecurse;
5618                          * *** HACK *** for now just treat as "no information".
5619                          * See [perl #56690].
5620                          */
5621                         ssc_init(pRExC_state, data->start_class);
5622                     }  else {
5623                         /* AND before and after: combine and continue.  These
5624                          * assertions are zero-length, so can match an EMPTY
5625                          * string */
5626                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5627                         ANYOF_FLAGS(data->start_class)
5628                                                    |= SSC_MATCHES_EMPTY_STRING;
5629                     }
5630                 }
5631             }
5632 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5633             else {
5634                 /* Positive Lookahead/lookbehind
5635                    In this case we can do fixed string optimisation,
5636                    but we must be careful about it. Note in the case of
5637                    lookbehind the positions will be offset by the minimum
5638                    length of the pattern, something we won't know about
5639                    until after the recurse.
5640                 */
5641                 SSize_t deltanext, fake = 0;
5642                 regnode *nscan;
5643                 regnode_ssc intrnl;
5644                 int f = 0;
5645                 /* We use SAVEFREEPV so that when the full compile
5646                     is finished perl will clean up the allocated
5647                     minlens when it's all done. This way we don't
5648                     have to worry about freeing them when we know
5649                     they wont be used, which would be a pain.
5650                  */
5651                 SSize_t *minnextp;
5652                 Newx( minnextp, 1, SSize_t );
5653                 SAVEFREEPV(minnextp);
5654
5655                 if (data) {
5656                     StructCopy(data, &data_fake, scan_data_t);
5657                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5658                         f |= SCF_DO_SUBSTR;
5659                         if (scan->flags)
5660                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5661                         data_fake.last_found=newSVsv(data->last_found);
5662                     }
5663                 }
5664                 else
5665                     data_fake.last_closep = &fake;
5666                 data_fake.flags = 0;
5667                 data_fake.pos_delta = delta;
5668                 if (is_inf)
5669                     data_fake.flags |= SF_IS_INF;
5670                 if ( flags & SCF_DO_STCLASS && !scan->flags
5671                      && OP(scan) == IFMATCH ) { /* Lookahead */
5672                     ssc_init(pRExC_state, &intrnl);
5673                     data_fake.start_class = &intrnl;
5674                     f |= SCF_DO_STCLASS_AND;
5675                 }
5676                 if (flags & SCF_WHILEM_VISITED_POS)
5677                     f |= SCF_WHILEM_VISITED_POS;
5678                 next = regnext(scan);
5679                 nscan = NEXTOPER(NEXTOPER(scan));
5680
5681                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5682                                         &deltanext, last, &data_fake,
5683                                         stopparen, recursed_depth, NULL,
5684                                         f,depth+1);
5685                 if (scan->flags) {
5686                     if (deltanext) {
5687                         FAIL("Variable length lookbehind not implemented");
5688                     }
5689                     else if (*minnextp > (I32)U8_MAX) {
5690                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5691                               (UV)U8_MAX);
5692                     }
5693                     scan->flags = (U8)*minnextp;
5694                 }
5695
5696                 *minnextp += min;
5697
5698                 if (f & SCF_DO_STCLASS_AND) {
5699                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5700                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5701                 }
5702                 if (data) {
5703                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5704                         pars++;
5705                     if (data_fake.flags & SF_HAS_EVAL)
5706                         data->flags |= SF_HAS_EVAL;
5707                     data->whilem_c = data_fake.whilem_c;
5708                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5709                         if (RExC_rx->minlen<*minnextp)
5710                             RExC_rx->minlen=*minnextp;
5711                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5712                         SvREFCNT_dec_NN(data_fake.last_found);
5713
5714                         if ( data_fake.minlen_fixed != minlenp )
5715                         {
5716                             data->offset_fixed= data_fake.offset_fixed;
5717                             data->minlen_fixed= data_fake.minlen_fixed;
5718                             data->lookbehind_fixed+= scan->flags;
5719                         }
5720                         if ( data_fake.minlen_float != minlenp )
5721                         {
5722                             data->minlen_float= data_fake.minlen_float;
5723                             data->offset_float_min=data_fake.offset_float_min;
5724                             data->offset_float_max=data_fake.offset_float_max;
5725                             data->lookbehind_float+= scan->flags;
5726                         }
5727                     }
5728                 }
5729             }
5730 #endif
5731         }
5732         else if (OP(scan) == OPEN) {
5733             if (stopparen != (I32)ARG(scan))
5734                 pars++;
5735         }
5736         else if (OP(scan) == CLOSE) {
5737             if (stopparen == (I32)ARG(scan)) {
5738                 break;
5739             }
5740             if ((I32)ARG(scan) == is_par) {
5741                 next = regnext(scan);
5742
5743                 if ( next && (OP(next) != WHILEM) && next < last)
5744                     is_par = 0;         /* Disable optimization */
5745             }
5746             if (data)
5747                 *(data->last_closep) = ARG(scan);
5748         }
5749         else if (OP(scan) == EVAL) {
5750                 if (data)
5751                     data->flags |= SF_HAS_EVAL;
5752         }
5753         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5754             if (flags & SCF_DO_SUBSTR) {
5755                 scan_commit(pRExC_state, data, minlenp, is_inf);
5756                 flags &= ~SCF_DO_SUBSTR;
5757             }
5758             if (data && OP(scan)==ACCEPT) {
5759                 data->flags |= SCF_SEEN_ACCEPT;
5760                 if (stopmin > min)
5761                     stopmin = min;
5762             }
5763         }
5764         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5765         {
5766                 if (flags & SCF_DO_SUBSTR) {
5767                     scan_commit(pRExC_state, data, minlenp, is_inf);
5768                     data->longest = &(data->longest_float);
5769                 }
5770                 is_inf = is_inf_internal = 1;
5771                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5772                     ssc_anything(data->start_class);
5773                 flags &= ~SCF_DO_STCLASS;
5774         }
5775         else if (OP(scan) == GPOS) {
5776             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5777                 !(delta || is_inf || (data && data->pos_delta)))
5778             {
5779                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5780                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5781                 if (RExC_rx->gofs < (STRLEN)min)
5782                     RExC_rx->gofs = min;
5783             } else {
5784                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5785                 RExC_rx->gofs = 0;
5786             }
5787         }
5788 #ifdef TRIE_STUDY_OPT
5789 #ifdef FULL_TRIE_STUDY
5790         else if (PL_regkind[OP(scan)] == TRIE) {
5791             /* NOTE - There is similar code to this block above for handling
5792                BRANCH nodes on the initial study.  If you change stuff here
5793                check there too. */
5794             regnode *trie_node= scan;
5795             regnode *tail= regnext(scan);
5796             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5797             SSize_t max1 = 0, min1 = SSize_t_MAX;
5798             regnode_ssc accum;
5799
5800             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5801                 /* Cannot merge strings after this. */
5802                 scan_commit(pRExC_state, data, minlenp, is_inf);
5803             }
5804             if (flags & SCF_DO_STCLASS)
5805                 ssc_init_zero(pRExC_state, &accum);
5806
5807             if (!trie->jump) {
5808                 min1= trie->minlen;
5809                 max1= trie->maxlen;
5810             } else {
5811                 const regnode *nextbranch= NULL;
5812                 U32 word;
5813
5814                 for ( word=1 ; word <= trie->wordcount ; word++)
5815                 {
5816                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5817                     regnode_ssc this_class;
5818
5819                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5820                     if (data) {
5821                         data_fake.whilem_c = data->whilem_c;
5822                         data_fake.last_closep = data->last_closep;
5823                     }
5824                     else
5825                         data_fake.last_closep = &fake;
5826                     data_fake.pos_delta = delta;
5827                     if (flags & SCF_DO_STCLASS) {
5828                         ssc_init(pRExC_state, &this_class);
5829                         data_fake.start_class = &this_class;
5830                         f = SCF_DO_STCLASS_AND;
5831                     }
5832                     if (flags & SCF_WHILEM_VISITED_POS)
5833                         f |= SCF_WHILEM_VISITED_POS;
5834
5835                     if (trie->jump[word]) {
5836                         if (!nextbranch)
5837                             nextbranch = trie_node + trie->jump[0];
5838                         scan= trie_node + trie->jump[word];
5839                         /* We go from the jump point to the branch that follows
5840                            it. Note this means we need the vestigal unused
5841                            branches even though they arent otherwise used. */
5842                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5843                             &deltanext, (regnode *)nextbranch, &data_fake,
5844                             stopparen, recursed_depth, NULL, f,depth+1);
5845                     }
5846                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5847                         nextbranch= regnext((regnode*)nextbranch);
5848
5849                     if (min1 > (SSize_t)(minnext + trie->minlen))
5850                         min1 = minnext + trie->minlen;
5851                     if (deltanext == SSize_t_MAX) {
5852                         is_inf = is_inf_internal = 1;
5853                         max1 = SSize_t_MAX;
5854                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5855                         max1 = minnext + deltanext + trie->maxlen;
5856
5857                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5858                         pars++;
5859                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5860                         if ( stopmin > min + min1)
5861                             stopmin = min + min1;
5862                         flags &= ~SCF_DO_SUBSTR;
5863                         if (data)
5864                             data->flags |= SCF_SEEN_ACCEPT;
5865                     }
5866                     if (data) {
5867                         if (data_fake.flags & SF_HAS_EVAL)
5868                             data->flags |= SF_HAS_EVAL;
5869                         data->whilem_c = data_fake.whilem_c;
5870                     }
5871                     if (flags & SCF_DO_STCLASS)
5872                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5873                 }
5874             }
5875             if (flags & SCF_DO_SUBSTR) {
5876                 data->pos_min += min1;
5877                 data->pos_delta += max1 - min1;
5878                 if (max1 != min1 || is_inf)
5879                     data->longest = &(data->longest_float);
5880             }
5881             min += min1;
5882             if (delta != SSize_t_MAX)
5883                 delta += max1 - min1;
5884             if (flags & SCF_DO_STCLASS_OR) {
5885                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5886                 if (min1) {
5887                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5888                     flags &= ~SCF_DO_STCLASS;
5889                 }
5890             }
5891             else if (flags & SCF_DO_STCLASS_AND) {
5892                 if (min1) {
5893                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5894                     flags &= ~SCF_DO_STCLASS;
5895                 }
5896                 else {
5897                     /* Switch to OR mode: cache the old value of
5898                      * data->start_class */
5899                     INIT_AND_WITHP;
5900                     StructCopy(data->start_class, and_withp, regnode_ssc);
5901                     flags &= ~SCF_DO_STCLASS_AND;
5902                     StructCopy(&accum, data->start_class, regnode_ssc);
5903                     flags |= SCF_DO_STCLASS_OR;
5904                 }
5905             }
5906             scan= tail;
5907             continue;
5908         }
5909 #else
5910         else if (PL_regkind[OP(scan)] == TRIE) {
5911             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5912             U8*bang=NULL;
5913
5914             min += trie->minlen;
5915             delta += (trie->maxlen - trie->minlen);
5916             flags &= ~SCF_DO_STCLASS; /* xxx */
5917             if (flags & SCF_DO_SUBSTR) {
5918                 /* Cannot expect anything... */
5919                 scan_commit(pRExC_state, data, minlenp, is_inf);
5920                 data->pos_min += trie->minlen;
5921                 data->pos_delta += (trie->maxlen - trie->minlen);
5922                 if (trie->maxlen != trie->minlen)
5923                     data->longest = &(data->longest_float);
5924             }
5925             if (trie->jump) /* no more substrings -- for now /grr*/
5926                flags &= ~SCF_DO_SUBSTR;
5927         }
5928 #endif /* old or new */
5929 #endif /* TRIE_STUDY_OPT */
5930
5931         /* Else: zero-length, ignore. */
5932         scan = regnext(scan);
5933     }
5934
5935   finish:
5936     if (frame) {
5937         /* we need to unwind recursion. */
5938         depth = depth - 1;
5939
5940         DEBUG_STUDYDATA("frame-end:",data,depth);
5941         DEBUG_PEEP("fend", scan, depth);
5942
5943         /* restore previous context */
5944         last = frame->last_regnode;
5945         scan = frame->next_regnode;
5946         stopparen = frame->stopparen;
5947         recursed_depth = frame->prev_recursed_depth;
5948
5949         RExC_frame_last = frame->prev_frame;
5950         frame = frame->this_prev_frame;
5951         goto fake_study_recurse;
5952     }
5953
5954     assert(!frame);
5955     DEBUG_STUDYDATA("pre-fin:",data,depth);
5956
5957     *scanp = scan;
5958     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5959
5960     if (flags & SCF_DO_SUBSTR && is_inf)
5961         data->pos_delta = SSize_t_MAX - data->pos_min;
5962     if (is_par > (I32)U8_MAX)
5963         is_par = 0;
5964     if (is_par && pars==1 && data) {
5965         data->flags |= SF_IN_PAR;
5966         data->flags &= ~SF_HAS_PAR;
5967     }
5968     else if (pars && data) {
5969         data->flags |= SF_HAS_PAR;
5970         data->flags &= ~SF_IN_PAR;
5971     }
5972     if (flags & SCF_DO_STCLASS_OR)
5973         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5974     if (flags & SCF_TRIE_RESTUDY)
5975         data->flags |=  SCF_TRIE_RESTUDY;
5976
5977     DEBUG_STUDYDATA("post-fin:",data,depth);
5978
5979     {
5980         SSize_t final_minlen= min < stopmin ? min : stopmin;
5981
5982         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
5983             if (final_minlen > SSize_t_MAX - delta)
5984                 RExC_maxlen = SSize_t_MAX;
5985             else if (RExC_maxlen < final_minlen + delta)
5986                 RExC_maxlen = final_minlen + delta;
5987         }
5988         return final_minlen;
5989     }
5990     NOT_REACHED; /* NOTREACHED */
5991 }
5992
5993 STATIC U32
5994 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5995 {
5996     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5997
5998     PERL_ARGS_ASSERT_ADD_DATA;
5999
6000     Renewc(RExC_rxi->data,
6001            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6002            char, struct reg_data);
6003     if(count)
6004         Renew(RExC_rxi->data->what, count + n, U8);
6005     else
6006         Newx(RExC_rxi->data->what, n, U8);
6007     RExC_rxi->data->count = count + n;
6008     Copy(s, RExC_rxi->data->what + count, n, U8);
6009     return count;
6010 }
6011
6012 /*XXX: todo make this not included in a non debugging perl, but appears to be
6013  * used anyway there, in 'use re' */
6014 #ifndef PERL_IN_XSUB_RE
6015 void
6016 Perl_reginitcolors(pTHX)
6017 {
6018     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6019     if (s) {
6020         char *t = savepv(s);
6021         int i = 0;
6022         PL_colors[0] = t;
6023         while (++i < 6) {
6024             t = strchr(t, '\t');
6025             if (t) {
6026                 *t = '\0';
6027                 PL_colors[i] = ++t;
6028             }
6029             else
6030                 PL_colors[i] = t = (char *)"";
6031         }
6032     } else {
6033         int i = 0;
6034         while (i < 6)
6035             PL_colors[i++] = (char *)"";
6036     }
6037     PL_colorset = 1;
6038 }
6039 #endif
6040
6041
6042 #ifdef TRIE_STUDY_OPT
6043 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6044     STMT_START {                                            \
6045         if (                                                \
6046               (data.flags & SCF_TRIE_RESTUDY)               \
6047               && ! restudied++                              \
6048         ) {                                                 \
6049             dOsomething;                                    \
6050             goto reStudy;                                   \
6051         }                                                   \
6052     } STMT_END
6053 #else
6054 #define CHECK_RESTUDY_GOTO_butfirst
6055 #endif
6056
6057 /*
6058  * pregcomp - compile a regular expression into internal code
6059  *
6060  * Decides which engine's compiler to call based on the hint currently in
6061  * scope
6062  */
6063
6064 #ifndef PERL_IN_XSUB_RE
6065
6066 /* return the currently in-scope regex engine (or the default if none)  */
6067
6068 regexp_engine const *
6069 Perl_current_re_engine(pTHX)
6070 {
6071     if (IN_PERL_COMPILETIME) {
6072         HV * const table = GvHV(PL_hintgv);
6073         SV **ptr;
6074
6075         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6076             return &PL_core_reg_engine;
6077         ptr = hv_fetchs(table, "regcomp", FALSE);
6078         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6079             return &PL_core_reg_engine;
6080         return INT2PTR(regexp_engine*,SvIV(*ptr));
6081     }
6082     else {
6083         SV *ptr;
6084         if (!PL_curcop->cop_hints_hash)
6085             return &PL_core_reg_engine;
6086         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6087         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6088             return &PL_core_reg_engine;
6089         return INT2PTR(regexp_engine*,SvIV(ptr));
6090     }
6091 }
6092
6093
6094 REGEXP *
6095 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6096 {
6097     regexp_engine const *eng = current_re_engine();
6098     GET_RE_DEBUG_FLAGS_DECL;
6099
6100     PERL_ARGS_ASSERT_PREGCOMP;
6101
6102     /* Dispatch a request to compile a regexp to correct regexp engine. */
6103     DEBUG_COMPILE_r({
6104         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6105                         PTR2UV(eng));
6106     });
6107     return CALLREGCOMP_ENG(eng, pattern, flags);
6108 }
6109 #endif
6110
6111 /* public(ish) entry point for the perl core's own regex compiling code.
6112  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6113  * pattern rather than a list of OPs, and uses the internal engine rather
6114  * than the current one */
6115
6116 REGEXP *
6117 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6118 {
6119     SV *pat = pattern; /* defeat constness! */
6120     PERL_ARGS_ASSERT_RE_COMPILE;
6121     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6122 #ifdef PERL_IN_XSUB_RE
6123                                 &my_reg_engine,
6124 #else
6125                                 &PL_core_reg_engine,
6126 #endif
6127                                 NULL, NULL, rx_flags, 0);
6128 }
6129
6130
6131 static void
6132 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6133 {
6134     int n;
6135
6136     if (--cbs->refcnt > 0)
6137         return;
6138     for (n = 0; n < cbs->count; n++) {
6139         REGEXP *rx = cbs->cb[n].src_regex;
6140         cbs->cb[n].src_regex = NULL;
6141         SvREFCNT_dec(rx);
6142     }
6143     Safefree(cbs->cb);
6144     Safefree(cbs);
6145 }
6146
6147
6148 static struct reg_code_blocks *
6149 S_alloc_code_blocks(pTHX_  int ncode)
6150 {
6151      struct reg_code_blocks *cbs;
6152     Newx(cbs, 1, struct reg_code_blocks);
6153     cbs->count = ncode;
6154     cbs->refcnt = 1;
6155     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6156     if (ncode)
6157         Newx(cbs->cb, ncode, struct reg_code_block);
6158     else
6159         cbs->cb = NULL;
6160     return cbs;
6161 }
6162
6163
6164 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6165  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6166  * point to the realloced string and length.
6167  *
6168  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6169  * stuff added */
6170
6171 static void
6172 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6173                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6174 {
6175     U8 *const src = (U8*)*pat_p;
6176     U8 *dst, *d;
6177     int n=0;
6178     STRLEN s = 0;
6179     bool do_end = 0;
6180     GET_RE_DEBUG_FLAGS_DECL;
6181
6182     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6183         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6184
6185     Newx(dst, *plen_p * 2 + 1, U8);
6186     d = dst;
6187
6188     while (s < *plen_p) {
6189         append_utf8_from_native_byte(src[s], &d);
6190
6191         if (n < num_code_blocks) {
6192             assert(pRExC_state->code_blocks);
6193             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6194                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6195                 assert(*(d - 1) == '(');
6196                 do_end = 1;
6197             }
6198             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6199                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6200                 assert(*(d - 1) == ')');
6201                 do_end = 0;
6202                 n++;
6203             }
6204         }
6205         s++;
6206     }
6207     *d = '\0';
6208     *plen_p = d - dst;
6209     *pat_p = (char*) dst;
6210     SAVEFREEPV(*pat_p);
6211     RExC_orig_utf8 = RExC_utf8 = 1;
6212 }
6213
6214
6215
6216 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6217  * while recording any code block indices, and handling overloading,
6218  * nested qr// objects etc.  If pat is null, it will allocate a new
6219  * string, or just return the first arg, if there's only one.
6220  *
6221  * Returns the malloced/updated pat.
6222  * patternp and pat_count is the array of SVs to be concatted;
6223  * oplist is the optional list of ops that generated the SVs;
6224  * recompile_p is a pointer to a boolean that will be set if
6225  *   the regex will need to be recompiled.
6226  * delim, if non-null is an SV that will be inserted between each element
6227  */
6228
6229 static SV*
6230 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6231                 SV *pat, SV ** const patternp, int pat_count,
6232                 OP *oplist, bool *recompile_p, SV *delim)
6233 {
6234     SV **svp;
6235     int n = 0;
6236     bool use_delim = FALSE;
6237     bool alloced = FALSE;
6238
6239     /* if we know we have at least two args, create an empty string,
6240      * then concatenate args to that. For no args, return an empty string */
6241     if (!pat && pat_count != 1) {
6242         pat = newSVpvs("");
6243         SAVEFREESV(pat);
6244         alloced = TRUE;
6245     }
6246
6247     for (svp = patternp; svp < patternp + pat_count; svp++) {
6248         SV *sv;
6249         SV *rx  = NULL;
6250         STRLEN orig_patlen = 0;
6251         bool code = 0;
6252         SV *msv = use_delim ? delim : *svp;
6253         if (!msv) msv = &PL_sv_undef;
6254
6255         /* if we've got a delimiter, we go round the loop twice for each
6256          * svp slot (except the last), using the delimiter the second
6257          * time round */
6258         if (use_delim) {
6259             svp--;
6260             use_delim = FALSE;
6261         }
6262         else if (delim)
6263             use_delim = TRUE;
6264
6265         if (SvTYPE(msv) == SVt_PVAV) {
6266             /* we've encountered an interpolated array within
6267              * the pattern, e.g. /...@a..../. Expand the list of elements,
6268              * then recursively append elements.
6269              * The code in this block is based on S_pushav() */
6270
6271             AV *const av = (AV*)msv;
6272             const SSize_t maxarg = AvFILL(av) + 1;
6273             SV **array;
6274
6275             if (oplist) {
6276                 assert(oplist->op_type == OP_PADAV
6277                     || oplist->op_type == OP_RV2AV);
6278                 oplist = OpSIBLING(oplist);
6279             }
6280
6281             if (SvRMAGICAL(av)) {
6282                 SSize_t i;
6283
6284                 Newx(array, maxarg, SV*);
6285                 SAVEFREEPV(array);
6286                 for (i=0; i < maxarg; i++) {
6287                     SV ** const svp = av_fetch(av, i, FALSE);
6288                     array[i] = svp ? *svp : &PL_sv_undef;
6289                 }
6290             }
6291             else
6292                 array = AvARRAY(av);
6293
6294             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6295                                 array, maxarg, NULL, recompile_p,
6296                                 /* $" */
6297                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6298
6299             continue;
6300         }
6301
6302
6303         /* we make the assumption here that each op in the list of
6304          * op_siblings maps to one SV pushed onto the stack,
6305          * except for code blocks, with have both an OP_NULL and
6306          * and OP_CONST.
6307          * This allows us to match up the list of SVs against the
6308          * list of OPs to find the next code block.
6309          *
6310          * Note that       PUSHMARK PADSV PADSV ..
6311          * is optimised to
6312          *                 PADRANGE PADSV  PADSV  ..
6313          * so the alignment still works. */
6314
6315         if (oplist) {
6316             if (oplist->op_type == OP_NULL
6317                 && (oplist->op_flags & OPf_SPECIAL))
6318             {
6319                 assert(n < pRExC_state->code_blocks->count);
6320                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6321                 pRExC_state->code_blocks->cb[n].block = oplist;
6322                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6323                 n++;
6324                 code = 1;
6325                 oplist = OpSIBLING(oplist); /* skip CONST */
6326                 assert(oplist);
6327             }
6328             oplist = OpSIBLING(oplist);;
6329         }
6330
6331         /* apply magic and QR overloading to arg */
6332
6333         SvGETMAGIC(msv);
6334         if (SvROK(msv) && SvAMAGIC(msv)) {
6335             SV *sv = AMG_CALLunary(msv, regexp_amg);
6336             if (sv) {
6337                 if (SvROK(sv))
6338                     sv = SvRV(sv);
6339                 if (SvTYPE(sv) != SVt_REGEXP)
6340                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6341                 msv = sv;
6342             }
6343         }
6344
6345         /* try concatenation overload ... */
6346         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6347                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6348         {
6349             sv_setsv(pat, sv);
6350             /* overloading involved: all bets are off over literal
6351              * code. Pretend we haven't seen it */
6352             if (n)
6353                 pRExC_state->code_blocks->count -= n;
6354             n = 0;
6355         }
6356         else  {
6357             /* ... or failing that, try "" overload */
6358             while (SvAMAGIC(msv)
6359                     && (sv = AMG_CALLunary(msv, string_amg))
6360                     && sv != msv
6361                     &&  !(   SvROK(msv)
6362                           && SvROK(sv)
6363                           && SvRV(msv) == SvRV(sv))
6364             ) {
6365                 msv = sv;
6366                 SvGETMAGIC(msv);
6367             }
6368             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6369                 msv = SvRV(msv);
6370
6371             if (pat) {
6372                 /* this is a partially unrolled
6373                  *     sv_catsv_nomg(pat, msv);
6374                  * that allows us to adjust code block indices if
6375                  * needed */
6376                 STRLEN dlen;
6377                 char *dst = SvPV_force_nomg(pat, dlen);
6378                 orig_patlen = dlen;
6379                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6380                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6381                     sv_setpvn(pat, dst, dlen);
6382                     SvUTF8_on(pat);
6383                 }
6384                 sv_catsv_nomg(pat, msv);
6385                 rx = msv;
6386             }
6387             else {
6388                 /* We have only one SV to process, but we need to verify
6389                  * it is properly null terminated or we will fail asserts
6390                  * later. In theory we probably shouldn't get such SV's,
6391                  * but if we do we should handle it gracefully. */
6392                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) ) {
6393                     /* not a string, or a string with a trailing null */
6394                     pat = msv;
6395                 } else {
6396                     /* a string with no trailing null, we need to copy it
6397                      * so it we have a trailing null */
6398                     pat = newSVsv(msv);
6399                 }
6400             }
6401
6402             if (code)
6403                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
6404         }
6405
6406         /* extract any code blocks within any embedded qr//'s */
6407         if (rx && SvTYPE(rx) == SVt_REGEXP
6408             && RX_ENGINE((REGEXP*)rx)->op_comp)
6409         {
6410
6411             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6412             if (ri->code_blocks && ri->code_blocks->count) {
6413                 int i;
6414                 /* the presence of an embedded qr// with code means
6415                  * we should always recompile: the text of the
6416                  * qr// may not have changed, but it may be a
6417                  * different closure than last time */
6418                 *recompile_p = 1;
6419                 if (pRExC_state->code_blocks) {
6420                     int new_count = pRExC_state->code_blocks->count
6421                             + ri->code_blocks->count;
6422                     Renew(pRExC_state->code_blocks->cb,
6423                             new_count, struct reg_code_block);
6424                     pRExC_state->code_blocks->count = new_count;
6425                 }
6426                 else
6427                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
6428                                                     ri->code_blocks->count);
6429
6430                 for (i=0; i < ri->code_blocks->count; i++) {
6431                     struct reg_code_block *src, *dst;
6432                     STRLEN offset =  orig_patlen
6433                         + ReANY((REGEXP *)rx)->pre_prefix;
6434                     assert(n < pRExC_state->code_blocks->count);
6435                     src = &ri->code_blocks->cb[i];
6436                     dst = &pRExC_state->code_blocks->cb[n];
6437                     dst->start      = src->start + offset;
6438                     dst->end        = src->end   + offset;
6439                     dst->block      = src->block;
6440                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6441                                             src->src_regex
6442                                                 ? src->src_regex
6443                                                 : (REGEXP*)rx);
6444                     n++;
6445                 }
6446             }
6447         }
6448     }
6449     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6450     if (alloced)
6451         SvSETMAGIC(pat);
6452
6453     return pat;
6454 }
6455
6456
6457
6458 /* see if there are any run-time code blocks in the pattern.
6459  * False positives are allowed */
6460
6461 static bool
6462 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6463                     char *pat, STRLEN plen)
6464 {
6465     int n = 0;
6466     STRLEN s;
6467     
6468     PERL_UNUSED_CONTEXT;
6469
6470     for (s = 0; s < plen; s++) {
6471         if (   pRExC_state->code_blocks
6472             && n < pRExC_state->code_blocks->count
6473             && s == pRExC_state->code_blocks->cb[n].start)
6474         {
6475             s = pRExC_state->code_blocks->cb[n].end;
6476             n++;
6477             continue;
6478         }
6479         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6480          * positives here */
6481         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6482             (pat[s+2] == '{'
6483                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6484         )
6485             return 1;
6486     }
6487     return 0;
6488 }
6489
6490 /* Handle run-time code blocks. We will already have compiled any direct
6491  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6492  * copy of it, but with any literal code blocks blanked out and
6493  * appropriate chars escaped; then feed it into
6494  *
6495  *    eval "qr'modified_pattern'"
6496  *
6497  * For example,
6498  *
6499  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6500  *
6501  * becomes
6502  *
6503  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6504  *
6505  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6506  * and merge them with any code blocks of the original regexp.
6507  *
6508  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6509  * instead, just save the qr and return FALSE; this tells our caller that
6510  * the original pattern needs upgrading to utf8.
6511  */
6512
6513 static bool
6514 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6515     char *pat, STRLEN plen)
6516 {
6517     SV *qr;
6518
6519     GET_RE_DEBUG_FLAGS_DECL;
6520
6521     if (pRExC_state->runtime_code_qr) {
6522         /* this is the second time we've been called; this should
6523          * only happen if the main pattern got upgraded to utf8
6524          * during compilation; re-use the qr we compiled first time
6525          * round (which should be utf8 too)
6526          */
6527         qr = pRExC_state->runtime_code_qr;
6528         pRExC_state->runtime_code_qr = NULL;
6529         assert(RExC_utf8 && SvUTF8(qr));
6530     }
6531     else {
6532         int n = 0;
6533         STRLEN s;
6534         char *p, *newpat;
6535         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
6536         SV *sv, *qr_ref;
6537         dSP;
6538
6539         /* determine how many extra chars we need for ' and \ escaping */
6540         for (s = 0; s < plen; s++) {
6541             if (pat[s] == '\'' || pat[s] == '\\')
6542                 newlen++;
6543         }
6544
6545         Newx(newpat, newlen, char);
6546         p = newpat;
6547         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6548
6549         for (s = 0; s < plen; s++) {
6550             if (   pRExC_state->code_blocks
6551                 && n < pRExC_state->code_blocks->count
6552                 && s == pRExC_state->code_blocks->cb[n].start)
6553             {
6554                 /* blank out literal code block */
6555                 assert(pat[s] == '(');
6556                 while (s <= pRExC_state->code_blocks->cb[n].end) {
6557                     *p++ = '_';
6558                     s++;
6559                 }
6560                 s--;
6561                 n++;
6562                 continue;
6563             }
6564             if (pat[s] == '\'' || pat[s] == '\\')
6565                 *p++ = '\\';
6566             *p++ = pat[s];
6567         }
6568         *p++ = '\'';
6569         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
6570             *p++ = 'x';
6571             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
6572                 *p++ = 'x';
6573             }
6574         }
6575         *p++ = '\0';
6576         DEBUG_COMPILE_r({
6577             Perl_re_printf( aTHX_
6578                 "%sre-parsing pattern for runtime code:%s %s\n",
6579                 PL_colors[4],PL_colors[5],newpat);
6580         });
6581
6582         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6583         Safefree(newpat);
6584
6585         ENTER;
6586         SAVETMPS;
6587         save_re_context();
6588         PUSHSTACKi(PERLSI_REQUIRE);
6589         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6590          * parsing qr''; normally only q'' does this. It also alters
6591          * hints handling */
6592         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6593         SvREFCNT_dec_NN(sv);
6594         SPAGAIN;
6595         qr_ref = POPs;
6596         PUTBACK;
6597         {
6598             SV * const errsv = ERRSV;
6599             if (SvTRUE_NN(errsv))
6600                 /* use croak_sv ? */
6601                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
6602         }
6603         assert(SvROK(qr_ref));
6604         qr = SvRV(qr_ref);
6605         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6606         /* the leaving below frees the tmp qr_ref.
6607          * Give qr a life of its own */
6608         SvREFCNT_inc(qr);
6609         POPSTACK;
6610         FREETMPS;
6611         LEAVE;
6612
6613     }
6614
6615     if (!RExC_utf8 && SvUTF8(qr)) {
6616         /* first time through; the pattern got upgraded; save the
6617          * qr for the next time through */
6618         assert(!pRExC_state->runtime_code_qr);
6619         pRExC_state->runtime_code_qr = qr;
6620         return 0;
6621     }
6622
6623
6624     /* extract any code blocks within the returned qr//  */
6625
6626
6627     /* merge the main (r1) and run-time (r2) code blocks into one */
6628     {
6629         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6630         struct reg_code_block *new_block, *dst;
6631         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6632         int i1 = 0, i2 = 0;
6633         int r1c, r2c;
6634
6635         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
6636         {
6637             SvREFCNT_dec_NN(qr);
6638             return 1;
6639         }
6640
6641         if (!r1->code_blocks)
6642             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
6643
6644         r1c = r1->code_blocks->count;
6645         r2c = r2->code_blocks->count;
6646
6647         Newx(new_block, r1c + r2c, struct reg_code_block);
6648
6649         dst = new_block;
6650
6651         while (i1 < r1c || i2 < r2c) {
6652             struct reg_code_block *src;
6653             bool is_qr = 0;
6654
6655             if (i1 == r1c) {
6656                 src = &r2->code_blocks->cb[i2++];
6657                 is_qr = 1;
6658             }
6659             else if (i2 == r2c)
6660                 src = &r1->code_blocks->cb[i1++];
6661             else if (  r1->code_blocks->cb[i1].start
6662                      < r2->code_blocks->cb[i2].start)
6663             {
6664                 src = &r1->code_blocks->cb[i1++];
6665                 assert(src->end < r2->code_blocks->cb[i2].start);
6666             }
6667             else {
6668                 assert(  r1->code_blocks->cb[i1].start
6669                        > r2->code_blocks->cb[i2].start);
6670                 src = &r2->code_blocks->cb[i2++];
6671                 is_qr = 1;
6672                 assert(src->end < r1->code_blocks->cb[i1].start);
6673             }
6674
6675             assert(pat[src->start] == '(');
6676             assert(pat[src->end]   == ')');
6677             dst->start      = src->start;
6678             dst->end        = src->end;
6679             dst->block      = src->block;
6680             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6681                                     : src->src_regex;
6682             dst++;
6683         }
6684         r1->code_blocks->count += r2c;
6685         Safefree(r1->code_blocks->cb);
6686         r1->code_blocks->cb = new_block;
6687     }
6688
6689     SvREFCNT_dec_NN(qr);
6690     return 1;
6691 }
6692
6693
6694 STATIC bool
6695 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6696                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6697                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6698                       STRLEN longest_length, bool eol, bool meol)
6699 {
6700     /* This is the common code for setting up the floating and fixed length
6701      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6702      * as to whether succeeded or not */
6703
6704     I32 t;
6705     SSize_t ml;
6706
6707     if (! (longest_length
6708            || (eol /* Can't have SEOL and MULTI */
6709                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6710           )
6711             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6712         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6713     {
6714         return FALSE;
6715     }
6716
6717     /* copy the information about the longest from the reg_scan_data
6718         over to the program. */
6719     if (SvUTF8(sv_longest)) {
6720         *rx_utf8 = sv_longest;
6721         *rx_substr = NULL;
6722     } else {
6723         *rx_substr = sv_longest;
6724         *rx_utf8 = NULL;
6725     }
6726     /* end_shift is how many chars that must be matched that
6727         follow this item. We calculate it ahead of time as once the
6728         lookbehind offset is added in we lose the ability to correctly
6729         calculate it.*/
6730     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6731     *rx_end_shift = ml - offset
6732         - longest_length
6733             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
6734              * intead? - DAPM
6735             + (SvTAIL(sv_longest) != 0)
6736             */
6737         + lookbehind;
6738
6739     t = (eol/* Can't have SEOL and MULTI */
6740          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6741     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6742
6743     return TRUE;
6744 }
6745
6746 /*
6747  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6748  * regular expression into internal code.
6749  * The pattern may be passed either as:
6750  *    a list of SVs (patternp plus pat_count)
6751  *    a list of OPs (expr)
6752  * If both are passed, the SV list is used, but the OP list indicates
6753  * which SVs are actually pre-compiled code blocks
6754  *
6755  * The SVs in the list have magic and qr overloading applied to them (and
6756  * the list may be modified in-place with replacement SVs in the latter
6757  * case).
6758  *
6759  * If the pattern hasn't changed from old_re, then old_re will be
6760  * returned.
6761  *
6762  * eng is the current engine. If that engine has an op_comp method, then
6763  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6764  * do the initial concatenation of arguments and pass on to the external
6765  * engine.
6766  *
6767  * If is_bare_re is not null, set it to a boolean indicating whether the
6768  * arg list reduced (after overloading) to a single bare regex which has
6769  * been returned (i.e. /$qr/).
6770  *
6771  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6772  *
6773  * pm_flags contains the PMf_* flags, typically based on those from the
6774  * pm_flags field of the related PMOP. Currently we're only interested in
6775  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6776  *
6777  * We can't allocate space until we know how big the compiled form will be,
6778  * but we can't compile it (and thus know how big it is) until we've got a
6779  * place to put the code.  So we cheat:  we compile it twice, once with code
6780  * generation turned off and size counting turned on, and once "for real".
6781  * This also means that we don't allocate space until we are sure that the
6782  * thing really will compile successfully, and we never have to move the
6783  * code and thus invalidate pointers into it.  (Note that it has to be in
6784  * one piece because free() must be able to free it all.) [NB: not true in perl]
6785  *
6786  * Beware that the optimization-preparation code in here knows about some
6787  * of the structure of the compiled regexp.  [I'll say.]
6788  */
6789
6790 REGEXP *
6791 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6792                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6793                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6794 {
6795     REGEXP *rx;
6796     struct regexp *r;
6797     regexp_internal *ri;
6798     STRLEN plen;
6799     char *exp;
6800     regnode *scan;
6801     I32 flags;
6802     SSize_t minlen = 0;
6803     U32 rx_flags;
6804     SV *pat;
6805     SV** new_patternp = patternp;
6806
6807     /* these are all flags - maybe they should be turned
6808      * into a single int with different bit masks */
6809     I32 sawlookahead = 0;
6810     I32 sawplus = 0;
6811     I32 sawopen = 0;
6812     I32 sawminmod = 0;
6813
6814     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6815     bool recompile = 0;
6816     bool runtime_code = 0;
6817     scan_data_t data;
6818     RExC_state_t RExC_state;
6819     RExC_state_t * const pRExC_state = &RExC_state;
6820 #ifdef TRIE_STUDY_OPT
6821     int restudied = 0;
6822     RExC_state_t copyRExC_state;
6823 #endif
6824     GET_RE_DEBUG_FLAGS_DECL;
6825
6826     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6827
6828     DEBUG_r(if (!PL_colorset) reginitcolors());
6829
6830     /* Initialize these here instead of as-needed, as is quick and avoids
6831      * having to test them each time otherwise */
6832     if (! PL_AboveLatin1) {
6833 #ifdef DEBUGGING
6834         char * dump_len_string;
6835 #endif
6836
6837         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6838         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6839         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6840         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6841         PL_HasMultiCharFold =
6842                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6843
6844         /* This is calculated here, because the Perl program that generates the
6845          * static global ones doesn't currently have access to
6846          * NUM_ANYOF_CODE_POINTS */
6847         PL_InBitmap = _new_invlist(2);
6848         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6849                                                     NUM_ANYOF_CODE_POINTS - 1);
6850 #ifdef DEBUGGING
6851         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6852         if (   ! dump_len_string
6853             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6854         {
6855             PL_dump_re_max_len = 0;
6856         }
6857 #endif
6858     }
6859
6860     pRExC_state->warn_text = NULL;
6861     pRExC_state->code_blocks = NULL;
6862
6863     if (is_bare_re)
6864         *is_bare_re = FALSE;
6865
6866     if (expr && (expr->op_type == OP_LIST ||
6867                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6868         /* allocate code_blocks if needed */
6869         OP *o;
6870         int ncode = 0;
6871
6872         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6873             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6874                 ncode++; /* count of DO blocks */
6875
6876         if (ncode)
6877             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
6878     }
6879
6880     if (!pat_count) {
6881         /* compile-time pattern with just OP_CONSTs and DO blocks */
6882
6883         int n;
6884         OP *o;
6885
6886         /* find how many CONSTs there are */
6887         assert(expr);
6888         n = 0;
6889         if (expr->op_type == OP_CONST)
6890             n = 1;
6891         else
6892             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6893                 if (o->op_type == OP_CONST)
6894                     n++;
6895             }
6896
6897         /* fake up an SV array */
6898
6899         assert(!new_patternp);
6900         Newx(new_patternp, n, SV*);
6901         SAVEFREEPV(new_patternp);
6902         pat_count = n;
6903
6904         n = 0;
6905         if (expr->op_type == OP_CONST)
6906             new_patternp[n] = cSVOPx_sv(expr);
6907         else
6908             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6909                 if (o->op_type == OP_CONST)
6910                     new_patternp[n++] = cSVOPo_sv;
6911             }
6912
6913     }
6914
6915     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6916         "Assembling pattern from %d elements%s\n", pat_count,
6917             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6918
6919     /* set expr to the first arg op */
6920
6921     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
6922          && expr->op_type != OP_CONST)
6923     {
6924             expr = cLISTOPx(expr)->op_first;
6925             assert(   expr->op_type == OP_PUSHMARK
6926                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6927                    || expr->op_type == OP_PADRANGE);
6928             expr = OpSIBLING(expr);
6929     }
6930
6931     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6932                         expr, &recompile, NULL);
6933
6934     /* handle bare (possibly after overloading) regex: foo =~ $re */
6935     {
6936         SV *re = pat;
6937         if (SvROK(re))
6938             re = SvRV(re);
6939         if (SvTYPE(re) == SVt_REGEXP) {
6940             if (is_bare_re)
6941                 *is_bare_re = TRUE;
6942             SvREFCNT_inc(re);
6943             DEBUG_PARSE_r(Perl_re_printf( aTHX_
6944                 "Precompiled pattern%s\n",
6945                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6946
6947             return (REGEXP*)re;
6948         }
6949     }
6950
6951     exp = SvPV_nomg(pat, plen);
6952
6953     if (!eng->op_comp) {
6954         if ((SvUTF8(pat) && IN_BYTES)
6955                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6956         {
6957             /* make a temporary copy; either to convert to bytes,
6958              * or to avoid repeating get-magic / overloaded stringify */
6959             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6960                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6961         }
6962         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6963     }
6964
6965     /* ignore the utf8ness if the pattern is 0 length */
6966     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6967
6968     RExC_uni_semantics = 0;
6969     RExC_seen_unfolded_sharp_s = 0;
6970     RExC_contains_locale = 0;
6971     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
6972     RExC_study_started = 0;
6973     pRExC_state->runtime_code_qr = NULL;
6974     RExC_frame_head= NULL;
6975     RExC_frame_last= NULL;
6976     RExC_frame_count= 0;
6977
6978     DEBUG_r({
6979         RExC_mysv1= sv_newmortal();
6980         RExC_mysv2= sv_newmortal();
6981     });
6982     DEBUG_COMPILE_r({
6983             SV *dsv= sv_newmortal();
6984             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6985             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
6986                           PL_colors[4],PL_colors[5],s);
6987         });
6988
6989   redo_first_pass:
6990     /* we jump here if we have to recompile, e.g., from upgrading the pattern
6991      * to utf8 */
6992
6993     if ((pm_flags & PMf_USE_RE_EVAL)
6994                 /* this second condition covers the non-regex literal case,
6995                  * i.e.  $foo =~ '(?{})'. */
6996                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6997     )
6998         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6999
7000     /* return old regex if pattern hasn't changed */
7001     /* XXX: note in the below we have to check the flags as well as the
7002      * pattern.
7003      *
7004      * Things get a touch tricky as we have to compare the utf8 flag
7005      * independently from the compile flags.  */
7006
7007     if (   old_re
7008         && !recompile
7009         && !!RX_UTF8(old_re) == !!RExC_utf8
7010         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7011         && RX_PRECOMP(old_re)
7012         && RX_PRELEN(old_re) == plen
7013         && memEQ(RX_PRECOMP(old_re), exp, plen)
7014         && !runtime_code /* with runtime code, always recompile */ )
7015     {
7016         return old_re;
7017     }
7018
7019     rx_flags = orig_rx_flags;
7020
7021     if (   initial_charset == REGEX_DEPENDS_CHARSET
7022         && (RExC_utf8 ||RExC_uni_semantics))
7023     {
7024
7025         /* Set to use unicode semantics if the pattern is in utf8 and has the
7026          * 'depends' charset specified, as it means unicode when utf8  */
7027         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7028     }
7029
7030     RExC_precomp = exp;
7031     RExC_precomp_adj = 0;
7032     RExC_flags = rx_flags;
7033     RExC_pm_flags = pm_flags;
7034
7035     if (runtime_code) {
7036         assert(TAINTING_get || !TAINT_get);
7037         if (TAINT_get)
7038             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7039
7040         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7041             /* whoops, we have a non-utf8 pattern, whilst run-time code
7042              * got compiled as utf8. Try again with a utf8 pattern */
7043             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7044                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7045             goto redo_first_pass;
7046         }
7047     }
7048     assert(!pRExC_state->runtime_code_qr);
7049
7050     RExC_sawback = 0;
7051
7052     RExC_seen = 0;
7053     RExC_maxlen = 0;
7054     RExC_in_lookbehind = 0;
7055     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7056     RExC_extralen = 0;
7057 #ifdef EBCDIC
7058     RExC_recode_x_to_native = 0;
7059 #endif
7060     RExC_in_multi_char_class = 0;
7061
7062     /* First pass: determine size, legality. */
7063     RExC_parse = exp;
7064     RExC_start = RExC_adjusted_start = exp;
7065     RExC_end = exp + plen;
7066     RExC_precomp_end = RExC_end;
7067     RExC_naughty = 0;
7068     RExC_npar = 1;
7069     RExC_nestroot = 0;
7070     RExC_size = 0L;
7071     RExC_emit = (regnode *) &RExC_emit_dummy;
7072     RExC_whilem_seen = 0;
7073     RExC_open_parens = NULL;
7074     RExC_close_parens = NULL;
7075     RExC_end_op = NULL;
7076     RExC_paren_names = NULL;
7077 #ifdef DEBUGGING
7078     RExC_paren_name_list = NULL;
7079 #endif
7080     RExC_recurse = NULL;
7081     RExC_study_chunk_recursed = NULL;
7082     RExC_study_chunk_recursed_bytes= 0;
7083     RExC_recurse_count = 0;
7084     pRExC_state->code_index = 0;
7085
7086     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7087      * code makes sure the final byte is an uncounted NUL.  But should this
7088      * ever not be the case, lots of things could read beyond the end of the
7089      * buffer: loops like
7090      *      while(isFOO(*RExC_parse)) RExC_parse++;
7091      *      strchr(RExC_parse, "foo");
7092      * etc.  So it is worth noting. */
7093     assert(*RExC_end == '\0');
7094
7095     DEBUG_PARSE_r(
7096         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7097         RExC_lastnum=0;
7098         RExC_lastparse=NULL;
7099     );
7100
7101     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7102         /* It's possible to write a regexp in ascii that represents Unicode
7103         codepoints outside of the byte range, such as via \x{100}. If we
7104         detect such a sequence we have to convert the entire pattern to utf8
7105         and then recompile, as our sizing calculation will have been based
7106         on 1 byte == 1 character, but we will need to use utf8 to encode
7107         at least some part of the pattern, and therefore must convert the whole
7108         thing.
7109         -- dmq */
7110         if (flags & RESTART_PASS1) {
7111             if (flags & NEED_UTF8) {
7112                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7113                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7114             }
7115             else {
7116                 DEBUG_PARSE_r(Perl_re_printf( aTHX_
7117                 "Need to redo pass 1\n"));
7118             }
7119
7120             goto redo_first_pass;
7121         }
7122         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
7123     }
7124
7125     DEBUG_PARSE_r({
7126         Perl_re_printf( aTHX_
7127             "Required size %" IVdf " nodes\n"
7128             "Starting second pass (creation)\n",
7129             (IV)RExC_size);
7130         RExC_lastnum=0;
7131         RExC_lastparse=NULL;
7132     });
7133
7134     /* The first pass could have found things that force Unicode semantics */
7135     if ((RExC_utf8 || RExC_uni_semantics)
7136          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7137     {
7138         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7139     }
7140
7141     /* Small enough for pointer-storage convention?
7142        If extralen==0, this means that we will not need long jumps. */
7143     if (RExC_size >= 0x10000L && RExC_extralen)
7144         RExC_size += RExC_extralen;
7145     else
7146         RExC_extralen = 0;
7147     if (RExC_whilem_seen > 15)
7148         RExC_whilem_seen = 15;
7149
7150     /* Allocate space and zero-initialize. Note, the two step process
7151        of zeroing when in debug mode, thus anything assigned has to
7152        happen after that */
7153     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7154     r = ReANY(rx);
7155     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7156          char, regexp_internal);
7157     if ( r == NULL || ri == NULL )
7158         FAIL("Regexp out of space");
7159 #ifdef DEBUGGING
7160     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7161     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7162          char);
7163 #else
7164     /* bulk initialize base fields with 0. */
7165     Zero(ri, sizeof(regexp_internal), char);
7166 #endif
7167
7168     /* non-zero initialization begins here */
7169     RXi_SET( r, ri );
7170     r->engine= eng;
7171     r->extflags = rx_flags;
7172     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7173
7174     if (pm_flags & PMf_IS_QR) {
7175         ri->code_blocks = pRExC_state->code_blocks;
7176         if (ri->code_blocks)
7177             ri->code_blocks->refcnt++;
7178     }
7179
7180     {
7181         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7182         bool has_charset = (get_regex_charset(r->extflags)
7183                                                     != REGEX_DEPENDS_CHARSET);
7184
7185         /* The caret is output if there are any defaults: if not all the STD
7186          * flags are set, or if no character set specifier is needed */
7187         bool has_default =
7188                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7189                     || ! has_charset);
7190         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7191                                                    == REG_RUN_ON_COMMENT_SEEN);
7192         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7193                             >> RXf_PMf_STD_PMMOD_SHIFT);
7194         const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7195         char *p;
7196
7197         /* We output all the necessary flags; we never output a minus, as all
7198          * those are defaults, so are
7199          * covered by the caret */
7200         const STRLEN wraplen = plen + has_p + has_runon
7201             + has_default       /* If needs a caret */
7202             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7203
7204                 /* If needs a character set specifier */
7205             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7206             + (sizeof("(?:)") - 1);
7207
7208         /* make sure PL_bitcount bounds not exceeded */
7209         assert(sizeof(STD_PAT_MODS) <= 8);
7210
7211         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
7212         r->xpv_len_u.xpvlenu_pv = p;
7213         if (RExC_utf8)
7214             SvFLAGS(rx) |= SVf_UTF8;
7215         *p++='('; *p++='?';
7216
7217         /* If a default, cover it using the caret */
7218         if (has_default) {
7219             *p++= DEFAULT_PAT_MOD;
7220         }
7221         if (has_charset) {
7222             STRLEN len;
7223             const char* const name = get_regex_charset_name(r->extflags, &len);
7224             Copy(name, p, len, char);
7225             p += len;
7226         }
7227         if (has_p)
7228             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7229         {
7230             char ch;
7231             while((ch = *fptr++)) {
7232                 if(reganch & 1)
7233                     *p++ = ch;
7234                 reganch >>= 1;
7235             }
7236         }
7237
7238         *p++ = ':';
7239         Copy(RExC_precomp, p, plen, char);
7240         assert ((RX_WRAPPED(rx) - p) < 16);
7241         r->pre_prefix = p - RX_WRAPPED(rx);
7242         p += plen;
7243         if (has_runon)
7244             *p++ = '\n';
7245         *p++ = ')';
7246         *p = 0;
7247         SvCUR_set(rx, p - RX_WRAPPED(rx));
7248     }
7249
7250     r->intflags = 0;
7251     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7252
7253     /* Useful during FAIL. */
7254 #ifdef RE_TRACK_PATTERN_OFFSETS
7255     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7256     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7257                           "%s %" UVuf " bytes for offset annotations.\n",
7258                           ri->u.offsets ? "Got" : "Couldn't get",
7259                           (UV)((2*RExC_size+1) * sizeof(U32))));
7260 #endif
7261     SetProgLen(ri,RExC_size);
7262     RExC_rx_sv = rx;
7263     RExC_rx = r;
7264     RExC_rxi = ri;
7265
7266     /* Second pass: emit code. */
7267     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7268     RExC_pm_flags = pm_flags;
7269     RExC_parse = exp;
7270     RExC_end = exp + plen;
7271     RExC_naughty = 0;
7272     RExC_emit_start = ri->program;
7273     RExC_emit = ri->program;
7274     RExC_emit_bound = ri->program + RExC_size + 1;
7275     pRExC_state->code_index = 0;
7276
7277     *((char*) RExC_emit++) = (char) REG_MAGIC;
7278     /* setup various meta data about recursion, this all requires
7279      * RExC_npar to be correctly set, and a bit later on we clear it */
7280     if (RExC_seen & REG_RECURSE_SEEN) {
7281         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7282             "%*s%*s Setting up open/close parens\n",
7283                   22, "|    |", (int)(0 * 2 + 1), ""));
7284
7285         /* setup RExC_open_parens, which holds the address of each
7286          * OPEN tag, and to make things simpler for the 0 index
7287          * the start of the program - this is used later for offsets */
7288         Newxz(RExC_open_parens, RExC_npar,regnode *);
7289         SAVEFREEPV(RExC_open_parens);
7290         RExC_open_parens[0] = RExC_emit;
7291
7292         /* setup RExC_close_parens, which holds the address of each
7293          * CLOSE tag, and to make things simpler for the 0 index
7294          * the end of the program - this is used later for offsets */
7295         Newxz(RExC_close_parens, RExC_npar,regnode *);
7296         SAVEFREEPV(RExC_close_parens);
7297         /* we dont know where end op starts yet, so we dont
7298          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7299
7300         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7301          * So its 1 if there are no parens. */
7302         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7303                                          ((RExC_npar & 0x07) != 0);
7304         Newx(RExC_study_chunk_recursed,
7305              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7306         SAVEFREEPV(RExC_study_chunk_recursed);
7307     }
7308     RExC_npar = 1;
7309     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7310         ReREFCNT_dec(rx);
7311         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#" UVxf, (UV) flags);
7312     }
7313     DEBUG_OPTIMISE_r(
7314         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7315     );
7316
7317     /* XXXX To minimize changes to RE engine we always allocate
7318        3-units-long substrs field. */
7319     Newx(r->substrs, 1, struct reg_substr_data);
7320     if (RExC_recurse_count) {
7321         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
7322         SAVEFREEPV(RExC_recurse);
7323     }
7324
7325   reStudy:
7326     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7327     DEBUG_r(
7328         RExC_study_chunk_recursed_count= 0;
7329     );
7330     Zero(r->substrs, 1, struct reg_substr_data);
7331     if (RExC_study_chunk_recursed) {
7332         Zero(RExC_study_chunk_recursed,
7333              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7334     }
7335
7336
7337 #ifdef TRIE_STUDY_OPT
7338     if (!restudied) {
7339         StructCopy(&zero_scan_data, &data, scan_data_t);
7340         copyRExC_state = RExC_state;
7341     } else {
7342         U32 seen=RExC_seen;
7343         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7344
7345         RExC_state = copyRExC_state;
7346         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7347             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7348         else
7349             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7350         StructCopy(&zero_scan_data, &data, scan_data_t);
7351     }
7352 #else
7353     StructCopy(&zero_scan_data, &data, scan_data_t);
7354 #endif
7355
7356     /* Dig out information for optimizations. */
7357     r->extflags = RExC_flags; /* was pm_op */
7358     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7359
7360     if (UTF)
7361         SvUTF8_on(rx);  /* Unicode in it? */
7362     ri->regstclass = NULL;
7363     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7364         r->intflags |= PREGf_NAUGHTY;
7365     scan = ri->program + 1;             /* First BRANCH. */
7366
7367     /* testing for BRANCH here tells us whether there is "must appear"
7368        data in the pattern. If there is then we can use it for optimisations */
7369     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7370                                                   */
7371         SSize_t fake;
7372         STRLEN longest_float_length, longest_fixed_length;
7373         regnode_ssc ch_class; /* pointed to by data */
7374         int stclass_flag;
7375         SSize_t last_close = 0; /* pointed to by data */
7376         regnode *first= scan;
7377         regnode *first_next= regnext(first);
7378         /*
7379          * Skip introductions and multiplicators >= 1
7380          * so that we can extract the 'meat' of the pattern that must
7381          * match in the large if() sequence following.
7382          * NOTE that EXACT is NOT covered here, as it is normally
7383          * picked up by the optimiser separately.
7384          *
7385          * This is unfortunate as the optimiser isnt handling lookahead
7386          * properly currently.
7387          *
7388          */
7389         while ((OP(first) == OPEN && (sawopen = 1)) ||
7390                /* An OR of *one* alternative - should not happen now. */
7391             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7392             /* for now we can't handle lookbehind IFMATCH*/
7393             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7394             (OP(first) == PLUS) ||
7395             (OP(first) == MINMOD) ||
7396                /* An {n,m} with n>0 */
7397             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7398             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7399         {
7400                 /*
7401                  * the only op that could be a regnode is PLUS, all the rest
7402                  * will be regnode_1 or regnode_2.
7403                  *
7404                  * (yves doesn't think this is true)
7405                  */
7406                 if (OP(first) == PLUS)
7407                     sawplus = 1;
7408                 else {
7409                     if (OP(first) == MINMOD)
7410                         sawminmod = 1;
7411                     first += regarglen[OP(first)];
7412                 }
7413                 first = NEXTOPER(first);
7414                 first_next= regnext(first);
7415         }
7416
7417         /* Starting-point info. */
7418       again:
7419         DEBUG_PEEP("first:",first,0);
7420         /* Ignore EXACT as we deal with it later. */
7421         if (PL_regkind[OP(first)] == EXACT) {
7422             if (OP(first) == EXACT || OP(first) == EXACTL)
7423                 NOOP;   /* Empty, get anchored substr later. */
7424             else
7425                 ri->regstclass = first;
7426         }
7427 #ifdef TRIE_STCLASS
7428         else if (PL_regkind[OP(first)] == TRIE &&
7429                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7430         {
7431             /* this can happen only on restudy */
7432             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7433         }
7434 #endif
7435         else if (REGNODE_SIMPLE(OP(first)))
7436             ri->regstclass = first;
7437         else if (PL_regkind[OP(first)] == BOUND ||
7438                  PL_regkind[OP(first)] == NBOUND)
7439             ri->regstclass = first;
7440         else if (PL_regkind[OP(first)] == BOL) {
7441             r->intflags |= (OP(first) == MBOL
7442                            ? PREGf_ANCH_MBOL
7443                            : PREGf_ANCH_SBOL);
7444             first = NEXTOPER(first);
7445             goto again;
7446         }
7447         else if (OP(first) == GPOS) {
7448             r->intflags |= PREGf_ANCH_GPOS;
7449             first = NEXTOPER(first);
7450             goto again;
7451         }
7452         else if ((!sawopen || !RExC_sawback) &&
7453             !sawlookahead &&
7454             (OP(first) == STAR &&
7455             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7456             !(r->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
7457         {
7458             /* turn .* into ^.* with an implied $*=1 */
7459             const int type =
7460                 (OP(NEXTOPER(first)) == REG_ANY)
7461                     ? PREGf_ANCH_MBOL
7462                     : PREGf_ANCH_SBOL;
7463             r->intflags |= (type | PREGf_IMPLICIT);
7464             first = NEXTOPER(first);
7465             goto again;
7466         }
7467         if (sawplus && !sawminmod && !sawlookahead
7468             && (!sawopen || !RExC_sawback)
7469             && !pRExC_state->code_blocks) /* May examine pos and $& */
7470             /* x+ must match at the 1st pos of run of x's */
7471             r->intflags |= PREGf_SKIP;
7472
7473         /* Scan is after the zeroth branch, first is atomic matcher. */
7474 #ifdef TRIE_STUDY_OPT
7475         DEBUG_PARSE_r(
7476             if (!restudied)
7477                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7478                               (IV)(first - scan + 1))
7479         );
7480 #else
7481         DEBUG_PARSE_r(
7482             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7483                 (IV)(first - scan + 1))
7484         );
7485 #endif
7486
7487
7488         /*
7489         * If there's something expensive in the r.e., find the
7490         * longest literal string that must appear and make it the
7491         * regmust.  Resolve ties in favor of later strings, since
7492         * the regstart check works with the beginning of the r.e.
7493         * and avoiding duplication strengthens checking.  Not a
7494         * strong reason, but sufficient in the absence of others.
7495         * [Now we resolve ties in favor of the earlier string if
7496         * it happens that c_offset_min has been invalidated, since the
7497         * earlier string may buy us something the later one won't.]
7498         */
7499
7500         data.longest_fixed = newSVpvs("");
7501         data.longest_float = newSVpvs("");
7502         data.last_found = newSVpvs("");
7503         data.longest = &(data.longest_fixed);
7504         ENTER_with_name("study_chunk");
7505         SAVEFREESV(data.longest_fixed);
7506         SAVEFREESV(data.longest_float);
7507         SAVEFREESV(data.last_found);
7508         first = scan;
7509         if (!ri->regstclass) {
7510             ssc_init(pRExC_state, &ch_class);
7511             data.start_class = &ch_class;
7512             stclass_flag = SCF_DO_STCLASS_AND;
7513         } else                          /* XXXX Check for BOUND? */
7514             stclass_flag = 0;
7515         data.last_closep = &last_close;
7516
7517         DEBUG_RExC_seen();
7518         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7519                              scan + RExC_size, /* Up to end */
7520             &data, -1, 0, NULL,
7521             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7522                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7523             0);
7524
7525
7526         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7527
7528
7529         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
7530              && data.last_start_min == 0 && data.last_end > 0
7531              && !RExC_seen_zerolen
7532              && !(RExC_seen & REG_VERBARG_SEEN)
7533              && !(RExC_seen & REG_GPOS_SEEN)
7534         ){
7535             r->extflags |= RXf_CHECK_ALL;
7536         }
7537         scan_commit(pRExC_state, &data,&minlen,0);
7538
7539         longest_float_length = CHR_SVLEN(data.longest_float);
7540
7541         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
7542                    && data.offset_fixed == data.offset_float_min
7543                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
7544             && S_setup_longest (aTHX_ pRExC_state,
7545                                     data.longest_float,
7546                                     &(r->float_utf8),
7547                                     &(r->float_substr),
7548                                     &(r->float_end_shift),
7549                                     data.lookbehind_float,
7550                                     data.offset_float_min,
7551                                     data.minlen_float,
7552                                     longest_float_length,
7553                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
7554                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
7555         {
7556             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
7557             r->float_max_offset = data.offset_float_max;
7558             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
7559                 r->float_max_offset -= data.lookbehind_float;
7560             SvREFCNT_inc_simple_void_NN(data.longest_float);
7561         }
7562         else {
7563             r->float_substr = r->float_utf8 = NULL;
7564             longest_float_length = 0;
7565         }
7566
7567         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
7568
7569         if (S_setup_longest (aTHX_ pRExC_state,
7570                                 data.longest_fixed,
7571                                 &(r->anchored_utf8),
7572                                 &(r->anchored_substr),
7573                                 &(r->anchored_end_shift),
7574                                 data.lookbehind_fixed,
7575                                 data.offset_fixed,
7576                                 data.minlen_fixed,
7577                                 longest_fixed_length,
7578                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7579                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7580         {
7581             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7582             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7583         }
7584         else {
7585             r->anchored_substr = r->anchored_utf8 = NULL;
7586             longest_fixed_length = 0;
7587         }
7588         LEAVE_with_name("study_chunk");
7589
7590         if (ri->regstclass
7591             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7592             ri->regstclass = NULL;
7593
7594         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7595             && stclass_flag
7596             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7597             && is_ssc_worth_it(pRExC_state, data.start_class))
7598         {
7599             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7600
7601             ssc_finalize(pRExC_state, data.start_class);
7602
7603             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7604             StructCopy(data.start_class,
7605                        (regnode_ssc*)RExC_rxi->data->data[n],
7606                        regnode_ssc);
7607             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7608             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7609             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7610                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7611                       Perl_re_printf( aTHX_
7612                                     "synthetic stclass \"%s\".\n",
7613                                     SvPVX_const(sv));});
7614             data.start_class = NULL;
7615         }
7616
7617         /* A temporary algorithm prefers floated substr to fixed one to dig
7618          * more info. */
7619         if (longest_fixed_length > longest_float_length) {
7620             r->substrs->check_ix = 0;
7621             r->check_end_shift = r->anchored_end_shift;
7622             r->check_substr = r->anchored_substr;
7623             r->check_utf8 = r->anchored_utf8;
7624             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7625             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7626                 r->intflags |= PREGf_NOSCAN;
7627         }
7628         else {
7629             r->substrs->check_ix = 1;
7630             r->check_end_shift = r->float_end_shift;
7631             r->check_substr = r->float_substr;
7632             r->check_utf8 = r->float_utf8;
7633             r->check_offset_min = r->float_min_offset;
7634             r->check_offset_max = r->float_max_offset;
7635         }
7636         if ((r->check_substr || r->check_utf8) ) {
7637             r->extflags |= RXf_USE_INTUIT;
7638             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7639                 r->extflags |= RXf_INTUIT_TAIL;
7640         }
7641         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7642
7643         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7644         if ( (STRLEN)minlen < longest_float_length )
7645             minlen= longest_float_length;
7646         if ( (STRLEN)minlen < longest_fixed_length )
7647             minlen= longest_fixed_length;
7648         */
7649     }
7650     else {
7651         /* Several toplevels. Best we can is to set minlen. */
7652         SSize_t fake;
7653         regnode_ssc ch_class;
7654         SSize_t last_close = 0;
7655
7656         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7657
7658         scan = ri->program + 1;
7659         ssc_init(pRExC_state, &ch_class);
7660         data.start_class = &ch_class;
7661         data.last_closep = &last_close;
7662
7663         DEBUG_RExC_seen();
7664         minlen = study_chunk(pRExC_state,
7665             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7666             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7667                                                       ? SCF_TRIE_DOING_RESTUDY
7668                                                       : 0),
7669             0);
7670
7671         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7672
7673         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7674                 = r->float_substr = r->float_utf8 = NULL;
7675
7676         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7677             && is_ssc_worth_it(pRExC_state, data.start_class))
7678         {
7679             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7680
7681             ssc_finalize(pRExC_state, data.start_class);
7682
7683             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7684             StructCopy(data.start_class,
7685                        (regnode_ssc*)RExC_rxi->data->data[n],
7686                        regnode_ssc);
7687             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7688             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7689             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7690                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7691                       Perl_re_printf( aTHX_
7692                                     "synthetic stclass \"%s\".\n",
7693                                     SvPVX_const(sv));});
7694             data.start_class = NULL;
7695         }
7696     }
7697
7698     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7699         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7700         r->maxlen = REG_INFTY;
7701     }
7702     else {
7703         r->maxlen = RExC_maxlen;
7704     }
7705
7706     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7707        the "real" pattern. */
7708     DEBUG_OPTIMISE_r({
7709         Perl_re_printf( aTHX_ "minlen: %" IVdf " r->minlen:%" IVdf " maxlen:%" IVdf "\n",
7710                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7711     });
7712     r->minlenret = minlen;
7713     if (r->minlen < minlen)
7714         r->minlen = minlen;
7715
7716     if (RExC_seen & REG_RECURSE_SEEN ) {
7717         r->intflags |= PREGf_RECURSE_SEEN;
7718         Newxz(r->recurse_locinput, r->nparens + 1, char *);
7719     }
7720     if (RExC_seen & REG_GPOS_SEEN)
7721         r->intflags |= PREGf_GPOS_SEEN;
7722     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7723         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7724                                                 lookbehind */
7725     if (pRExC_state->code_blocks)
7726         r->extflags |= RXf_EVAL_SEEN;
7727     if (RExC_seen & REG_VERBARG_SEEN)
7728     {
7729         r->intflags |= PREGf_VERBARG_SEEN;
7730         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7731     }
7732     if (RExC_seen & REG_CUTGROUP_SEEN)
7733         r->intflags |= PREGf_CUTGROUP_SEEN;
7734     if (pm_flags & PMf_USE_RE_EVAL)
7735         r->intflags |= PREGf_USE_RE_EVAL;
7736     if (RExC_paren_names)
7737         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7738     else
7739         RXp_PAREN_NAMES(r) = NULL;
7740
7741     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7742      * so it can be used in pp.c */
7743     if (r->intflags & PREGf_ANCH)
7744         r->extflags |= RXf_IS_ANCHORED;
7745
7746
7747     {
7748         /* this is used to identify "special" patterns that might result
7749          * in Perl NOT calling the regex engine and instead doing the match "itself",
7750          * particularly special cases in split//. By having the regex compiler
7751          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7752          * we avoid weird issues with equivalent patterns resulting in different behavior,
7753          * AND we allow non Perl engines to get the same optimizations by the setting the
7754          * flags appropriately - Yves */
7755         regnode *first = ri->program + 1;
7756         U8 fop = OP(first);
7757         regnode *next = regnext(first);
7758         U8 nop = OP(next);
7759
7760         if (PL_regkind[fop] == NOTHING && nop == END)
7761             r->extflags |= RXf_NULL;
7762         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7763             /* when fop is SBOL first->flags will be true only when it was
7764              * produced by parsing /\A/, and not when parsing /^/. This is
7765              * very important for the split code as there we want to
7766              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7767              * See rt #122761 for more details. -- Yves */
7768             r->extflags |= RXf_START_ONLY;
7769         else if (fop == PLUS
7770                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7771                  && nop == END)
7772             r->extflags |= RXf_WHITE;
7773         else if ( r->extflags & RXf_SPLIT
7774                   && (fop == EXACT || fop == EXACTL)
7775                   && STR_LEN(first) == 1
7776                   && *(STRING(first)) == ' '
7777                   && nop == END )
7778             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7779
7780     }
7781
7782     if (RExC_contains_locale) {
7783         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7784     }
7785
7786 #ifdef DEBUGGING
7787     if (RExC_paren_names) {
7788         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7789         ri->data->data[ri->name_list_idx]
7790                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7791     } else
7792 #endif
7793     ri->name_list_idx = 0;
7794
7795     while ( RExC_recurse_count > 0 ) {
7796         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7797         /*
7798          * This data structure is set up in study_chunk() and is used
7799          * to calculate the distance between a GOSUB regopcode and
7800          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
7801          * it refers to.
7802          *
7803          * If for some reason someone writes code that optimises
7804          * away a GOSUB opcode then the assert should be changed to
7805          * an if(scan) to guard the ARG2L_SET() - Yves
7806          *
7807          */
7808         assert(scan && OP(scan) == GOSUB);
7809         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7810     }
7811
7812     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7813     /* assume we don't need to swap parens around before we match */
7814     DEBUG_TEST_r({
7815         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7816             (unsigned long)RExC_study_chunk_recursed_count);
7817     });
7818     DEBUG_DUMP_r({
7819         DEBUG_RExC_seen();
7820         Perl_re_printf( aTHX_ "Final program:\n");
7821         regdump(r);
7822     });
7823 #ifdef RE_TRACK_PATTERN_OFFSETS
7824     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7825         const STRLEN len = ri->u.offsets[0];
7826         STRLEN i;
7827         GET_RE_DEBUG_FLAGS_DECL;
7828         Perl_re_printf( aTHX_
7829                       "Offsets: [%" UVuf "]\n\t", (UV)ri->u.offsets[0]);
7830         for (i = 1; i <= len; i++) {
7831             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7832                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7833                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7834             }
7835         Perl_re_printf( aTHX_  "\n");
7836     });
7837 #endif
7838
7839 #ifdef USE_ITHREADS
7840     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7841      * by setting the regexp SV to readonly-only instead. If the
7842      * pattern's been recompiled, the USEDness should remain. */
7843     if (old_re && SvREADONLY(old_re))
7844         SvREADONLY_on(rx);
7845 #endif
7846     return rx;
7847 }
7848
7849
7850 SV*
7851 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7852                     const U32 flags)
7853 {
7854     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7855
7856     PERL_UNUSED_ARG(value);
7857
7858     if (flags & RXapif_FETCH) {
7859         return reg_named_buff_fetch(rx, key, flags);
7860     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7861         Perl_croak_no_modify();
7862         return NULL;
7863     } else if (flags & RXapif_EXISTS) {
7864         return reg_named_buff_exists(rx, key, flags)
7865             ? &PL_sv_yes
7866             : &PL_sv_no;
7867     } else if (flags & RXapif_REGNAMES) {
7868         return reg_named_buff_all(rx, flags);
7869     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7870         return reg_named_buff_scalar(rx, flags);
7871     } else {
7872         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7873         return NULL;
7874     }
7875 }
7876
7877 SV*
7878 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7879                          const U32 flags)
7880 {
7881     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7882     PERL_UNUSED_ARG(lastkey);
7883
7884     if (flags & RXapif_FIRSTKEY)
7885         return reg_named_buff_firstkey(rx, flags);
7886     else if (flags & RXapif_NEXTKEY)
7887         return reg_named_buff_nextkey(rx, flags);
7888     else {
7889         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7890                                             (int)flags);
7891         return NULL;
7892     }
7893 }
7894
7895 SV*
7896 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7897                           const U32 flags)
7898 {
7899     SV *ret;
7900     struct regexp *const rx = ReANY(r);
7901
7902     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7903
7904     if (rx && RXp_PAREN_NAMES(rx)) {
7905         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7906         if (he_str) {
7907             IV i;
7908             SV* sv_dat=HeVAL(he_str);
7909             I32 *nums=(I32*)SvPVX(sv_dat);
7910             AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
7911             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7912                 if ((I32)(rx->nparens) >= nums[i]
7913                     && rx->offs[nums[i]].start != -1
7914                     && rx->offs[nums[i]].end != -1)
7915                 {
7916                     ret = newSVpvs("");
7917                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7918                     if (!retarray)
7919                         return ret;
7920                 } else {
7921                     if (retarray)
7922                         ret = newSVsv(&PL_sv_undef);
7923                 }
7924                 if (retarray)
7925                     av_push(retarray, ret);
7926             }
7927             if (retarray)
7928                 return newRV_noinc(MUTABLE_SV(retarray));
7929         }
7930     }
7931     return NULL;
7932 }
7933
7934 bool
7935 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7936                            const U32 flags)
7937 {
7938     struct regexp *const rx = ReANY(r);
7939
7940     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7941
7942     if (rx && RXp_PAREN_NAMES(rx)) {
7943         if (flags & RXapif_ALL) {
7944             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7945         } else {
7946             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7947             if (sv) {
7948                 SvREFCNT_dec_NN(sv);
7949                 return TRUE;
7950             } else {
7951                 return FALSE;
7952             }
7953         }
7954     } else {
7955         return FALSE;
7956     }
7957 }
7958
7959 SV*
7960 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7961 {
7962     struct regexp *const rx = ReANY(r);
7963
7964     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7965
7966     if ( rx && RXp_PAREN_NAMES(rx) ) {
7967         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7968
7969         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7970     } else {
7971         return FALSE;
7972     }
7973 }
7974
7975 SV*
7976 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7977 {
7978     struct regexp *const rx = ReANY(r);
7979     GET_RE_DEBUG_FLAGS_DECL;
7980
7981     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7982
7983     if (rx && RXp_PAREN_NAMES(rx)) {
7984         HV *hv = RXp_PAREN_NAMES(rx);
7985         HE *temphe;
7986         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7987             IV i;
7988             IV parno = 0;
7989             SV* sv_dat = HeVAL(temphe);
7990             I32 *nums = (I32*)SvPVX(sv_dat);
7991             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7992                 if ((I32)(rx->lastparen) >= nums[i] &&
7993                     rx->offs[nums[i]].start != -1 &&
7994                     rx->offs[nums[i]].end != -1)
7995                 {
7996                     parno = nums[i];
7997                     break;
7998                 }
7999             }
8000             if (parno || flags & RXapif_ALL) {
8001                 return newSVhek(HeKEY_hek(temphe));
8002             }
8003         }
8004     }
8005     return NULL;
8006 }
8007
8008 SV*
8009 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8010 {
8011     SV *ret;
8012     AV *av;
8013     SSize_t length;
8014     struct regexp *const rx = ReANY(r);
8015
8016     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8017
8018     if (rx && RXp_PAREN_NAMES(rx)) {
8019         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8020             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8021         } else if (flags & RXapif_ONE) {
8022             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8023             av = MUTABLE_AV(SvRV(ret));
8024             length = av_tindex(av);
8025             SvREFCNT_dec_NN(ret);
8026             return newSViv(length + 1);
8027         } else {
8028             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8029                                                 (int)flags);
8030             return NULL;
8031         }
8032     }
8033     return &PL_sv_undef;
8034 }
8035
8036 SV*
8037 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8038 {
8039     struct regexp *const rx = ReANY(r);
8040     AV *av = newAV();
8041
8042     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8043
8044     if (rx && RXp_PAREN_NAMES(rx)) {
8045         HV *hv= RXp_PAREN_NAMES(rx);
8046         HE *temphe;
8047         (void)hv_iterinit(hv);
8048         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8049             IV i;
8050             IV parno = 0;
8051             SV* sv_dat = HeVAL(temphe);
8052             I32 *nums = (I32*)SvPVX(sv_dat);
8053             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8054                 if ((I32)(rx->lastparen) >= nums[i] &&
8055                     rx->offs[nums[i]].start != -1 &&
8056                     rx->offs[nums[i]].end != -1)
8057                 {
8058                     parno = nums[i];
8059                     break;
8060                 }
8061             }
8062             if (parno || flags & RXapif_ALL) {
8063                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8064             }
8065         }
8066     }
8067
8068     return newRV_noinc(MUTABLE_SV(av));
8069 }
8070
8071 void
8072 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8073                              SV * const sv)
8074 {
8075     struct regexp *const rx = ReANY(r);
8076     char *s = NULL;
8077     SSize_t i = 0;
8078     SSize_t s1, t1;
8079     I32 n = paren;
8080
8081     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8082
8083     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8084            || n == RX_BUFF_IDX_CARET_FULLMATCH
8085            || n == RX_BUFF_IDX_CARET_POSTMATCH
8086        )
8087     {
8088         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8089         if (!keepcopy) {
8090             /* on something like
8091              *    $r = qr/.../;
8092              *    /$qr/p;
8093              * the KEEPCOPY is set on the PMOP rather than the regex */
8094             if (PL_curpm && r == PM_GETRE(PL_curpm))
8095                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8096         }
8097         if (!keepcopy)
8098             goto ret_undef;
8099     }
8100
8101     if (!rx->subbeg)
8102         goto ret_undef;
8103
8104     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8105         /* no need to distinguish between them any more */
8106         n = RX_BUFF_IDX_FULLMATCH;
8107
8108     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8109         && rx->offs[0].start != -1)
8110     {
8111         /* $`, ${^PREMATCH} */
8112         i = rx->offs[0].start;
8113         s = rx->subbeg;
8114     }
8115     else
8116     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8117         && rx->offs[0].end != -1)
8118     {
8119         /* $', ${^POSTMATCH} */
8120         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8121         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8122     }
8123     else
8124     if ( 0 <= n && n <= (I32)rx->nparens &&
8125         (s1 = rx->offs[n].start) != -1 &&
8126         (t1 = rx->offs[n].end) != -1)
8127     {
8128         /* $&, ${^MATCH},  $1 ... */
8129         i = t1 - s1;
8130         s = rx->subbeg + s1 - rx->suboffset;
8131     } else {
8132         goto ret_undef;
8133     }
8134
8135     assert(s >= rx->subbeg);
8136     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8137     if (i >= 0) {
8138 #ifdef NO_TAINT_SUPPORT
8139         sv_setpvn(sv, s, i);
8140 #else
8141         const int oldtainted = TAINT_get;
8142         TAINT_NOT;
8143         sv_setpvn(sv, s, i);
8144         TAINT_set(oldtainted);
8145 #endif
8146         if (RXp_MATCH_UTF8(rx))
8147             SvUTF8_on(sv);
8148         else
8149             SvUTF8_off(sv);
8150         if (TAINTING_get) {
8151             if (RXp_MATCH_TAINTED(rx)) {
8152                 if (SvTYPE(sv) >= SVt_PVMG) {
8153                     MAGIC* const mg = SvMAGIC(sv);
8154                     MAGIC* mgt;
8155                     TAINT;
8156                     SvMAGIC_set(sv, mg->mg_moremagic);
8157                     SvTAINT(sv);
8158                     if ((mgt = SvMAGIC(sv))) {
8159                         mg->mg_moremagic = mgt;
8160                         SvMAGIC_set(sv, mg);
8161                     }
8162                 } else {
8163                     TAINT;
8164                     SvTAINT(sv);
8165                 }
8166             } else
8167                 SvTAINTED_off(sv);
8168         }
8169     } else {
8170       ret_undef:
8171         sv_set_undef(sv);
8172         return;
8173     }
8174 }
8175
8176 void
8177 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8178                                                          SV const * const value)
8179 {
8180     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8181
8182     PERL_UNUSED_ARG(rx);
8183     PERL_UNUSED_ARG(paren);
8184     PERL_UNUSED_ARG(value);
8185
8186     if (!PL_localizing)
8187         Perl_croak_no_modify();
8188 }
8189
8190 I32
8191 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8192                               const I32 paren)
8193 {
8194     struct regexp *const rx = ReANY(r);
8195     I32 i;
8196     I32 s1, t1;
8197
8198     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8199
8200     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8201         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8202         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8203     )
8204     {
8205         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8206         if (!keepcopy) {
8207             /* on something like
8208              *    $r = qr/.../;
8209              *    /$qr/p;
8210              * the KEEPCOPY is set on the PMOP rather than the regex */
8211             if (PL_curpm && r == PM_GETRE(PL_curpm))
8212                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8213         }
8214         if (!keepcopy)
8215             goto warn_undef;
8216     }
8217
8218     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8219     switch (paren) {
8220       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8221       case RX_BUFF_IDX_PREMATCH:       /* $` */
8222         if (rx->offs[0].start != -1) {
8223                         i = rx->offs[0].start;
8224                         if (i > 0) {
8225                                 s1 = 0;
8226                                 t1 = i;
8227                                 goto getlen;
8228                         }
8229             }
8230         return 0;
8231
8232       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8233       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8234             if (rx->offs[0].end != -1) {
8235                         i = rx->sublen - rx->offs[0].end;
8236                         if (i > 0) {
8237                                 s1 = rx->offs[0].end;
8238                                 t1 = rx->sublen;
8239                                 goto getlen;
8240                         }
8241             }
8242         return 0;
8243
8244       default: /* $& / ${^MATCH}, $1, $2, ... */
8245             if (paren <= (I32)rx->nparens &&
8246             (s1 = rx->offs[paren].start) != -1 &&
8247             (t1 = rx->offs[paren].end) != -1)
8248             {
8249             i = t1 - s1;
8250             goto getlen;
8251         } else {
8252           warn_undef:
8253             if (ckWARN(WARN_UNINITIALIZED))
8254                 report_uninit((const SV *)sv);
8255             return 0;
8256         }
8257     }
8258   getlen:
8259     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8260         const char * const s = rx->subbeg - rx->suboffset + s1;
8261         const U8 *ep;
8262         STRLEN el;
8263
8264         i = t1 - s1;
8265         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8266                         i = el;
8267     }
8268     return i;
8269 }
8270
8271 SV*
8272 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8273 {
8274     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8275         PERL_UNUSED_ARG(rx);
8276         if (0)
8277             return NULL;
8278         else
8279             return newSVpvs("Regexp");
8280 }
8281
8282 /* Scans the name of a named buffer from the pattern.
8283  * If flags is REG_RSN_RETURN_NULL returns null.
8284  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8285  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8286  * to the parsed name as looked up in the RExC_paren_names hash.
8287  * If there is an error throws a vFAIL().. type exception.
8288  */
8289
8290 #define REG_RSN_RETURN_NULL    0
8291 #define REG_RSN_RETURN_NAME    1
8292 #define REG_RSN_RETURN_DATA    2
8293
8294 STATIC SV*
8295 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8296 {
8297     char *name_start = RExC_parse;
8298
8299     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8300
8301     assert (RExC_parse <= RExC_end);
8302     if (RExC_parse == RExC_end) NOOP;
8303     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8304          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8305           * using do...while */
8306         if (UTF)
8307             do {
8308                 RExC_parse += UTF8SKIP(RExC_parse);
8309             } while (   RExC_parse < RExC_end
8310                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8311         else
8312             do {
8313                 RExC_parse++;
8314             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8315     } else {
8316         RExC_parse++; /* so the <- from the vFAIL is after the offending
8317                          character */
8318         vFAIL("Group name must start with a non-digit word character");
8319     }
8320     if ( flags ) {
8321         SV* sv_name
8322             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8323                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8324         if ( flags == REG_RSN_RETURN_NAME)
8325             return sv_name;
8326         else if (flags==REG_RSN_RETURN_DATA) {
8327             HE *he_str = NULL;
8328             SV *sv_dat = NULL;
8329             if ( ! sv_name )      /* should not happen*/
8330                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8331             if (RExC_paren_names)
8332                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8333             if ( he_str )
8334                 sv_dat = HeVAL(he_str);
8335             if ( ! sv_dat )
8336                 vFAIL("Reference to nonexistent named group");
8337             return sv_dat;
8338         }
8339         else {
8340             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8341                        (unsigned long) flags);
8342         }
8343         NOT_REACHED; /* NOTREACHED */
8344     }
8345     return NULL;
8346 }
8347
8348 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8349     int num;                                                    \
8350     if (RExC_lastparse!=RExC_parse) {                           \
8351         Perl_re_printf( aTHX_  "%s",                                        \
8352             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8353                 RExC_end - RExC_parse, 16,                      \
8354                 "", "",                                         \
8355                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8356                 PERL_PV_PRETTY_ELLIPSES   |                     \
8357                 PERL_PV_PRETTY_LTGT       |                     \
8358                 PERL_PV_ESCAPE_RE         |                     \
8359                 PERL_PV_PRETTY_EXACTSIZE                        \
8360             )                                                   \
8361         );                                                      \
8362     } else                                                      \
8363         Perl_re_printf( aTHX_ "%16s","");                                   \
8364                                                                 \
8365     if (SIZE_ONLY)                                              \
8366        num = RExC_size + 1;                                     \
8367     else                                                        \
8368        num=REG_NODE_NUM(RExC_emit);                             \
8369     if (RExC_lastnum!=num)                                      \
8370        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8371     else                                                        \
8372        Perl_re_printf( aTHX_ "|%4s","");                                    \
8373     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8374         (int)((depth*2)), "",                                   \
8375         (funcname)                                              \
8376     );                                                          \
8377     RExC_lastnum=num;                                           \
8378     RExC_lastparse=RExC_parse;                                  \
8379 })
8380
8381
8382
8383 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8384     DEBUG_PARSE_MSG((funcname));                            \
8385     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8386 })
8387 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8388     DEBUG_PARSE_MSG((funcname));                            \
8389     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8390 })
8391
8392 /* This section of code defines the inversion list object and its methods.  The
8393  * interfaces are highly subject to change, so as much as possible is static to
8394  * this file.  An inversion list is here implemented as a malloc'd C UV array
8395  * as an SVt_INVLIST scalar.
8396  *
8397  * An inversion list for Unicode is an array of code points, sorted by ordinal
8398  * number.  Each element gives the code point that begins a range that extends
8399  * up-to but not including the code point given by the next element.  The final
8400  * element gives the first code point of a range that extends to the platform's
8401  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8402  * ...) give ranges whose code points are all in the inversion list.  We say
8403  * that those ranges are in the set.  The odd-numbered elements give ranges
8404  * whose code points are not in the inversion list, and hence not in the set.
8405  * Thus, element [0] is the first code point in the list.  Element [1]
8406  * is the first code point beyond that not in the list; and element [2] is the
8407  * first code point beyond that that is in the list.  In other words, the first
8408  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8409  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8410  * all code points in that range are not in the inversion list.  The third
8411  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8412  * list, and so forth.  Thus every element whose index is divisible by two
8413  * gives the beginning of a range that is in the list, and every element whose
8414  * index is not divisible by two gives the beginning of a range not in the
8415  * list.  If the final element's index is divisible by two, the inversion list
8416  * extends to the platform's infinity; otherwise the highest code point in the
8417  * inversion list is the contents of that element minus 1.
8418  *
8419  * A range that contains just a single code point N will look like
8420  *  invlist[i]   == N
8421  *  invlist[i+1] == N+1
8422  *
8423  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8424  * impossible to represent, so element [i+1] is omitted.  The single element
8425  * inversion list
8426  *  invlist[0] == UV_MAX
8427  * contains just UV_MAX, but is interpreted as matching to infinity.
8428  *
8429  * Taking the complement (inverting) an inversion list is quite simple, if the
8430  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8431  * This implementation reserves an element at the beginning of each inversion
8432  * list to always contain 0; there is an additional flag in the header which
8433  * indicates if the list begins at the 0, or is offset to begin at the next
8434  * element.  This means that the inversion list can be inverted without any
8435  * copying; just flip the flag.
8436  *
8437  * More about inversion lists can be found in "Unicode Demystified"
8438  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8439  *
8440  * The inversion list data structure is currently implemented as an SV pointing
8441  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8442  * array of UV whose memory management is automatically handled by the existing
8443  * facilities for SV's.
8444  *
8445  * Some of the methods should always be private to the implementation, and some
8446  * should eventually be made public */
8447
8448 /* The header definitions are in F<invlist_inline.h> */
8449
8450 #ifndef PERL_IN_XSUB_RE
8451
8452 PERL_STATIC_INLINE UV*
8453 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8454 {
8455     /* Returns a pointer to the first element in the inversion list's array.
8456      * This is called upon initialization of an inversion list.  Where the
8457      * array begins depends on whether the list has the code point U+0000 in it
8458      * or not.  The other parameter tells it whether the code that follows this
8459      * call is about to put a 0 in the inversion list or not.  The first
8460      * element is either the element reserved for 0, if TRUE, or the element
8461      * after it, if FALSE */
8462
8463     bool* offset = get_invlist_offset_addr(invlist);
8464     UV* zero_addr = (UV *) SvPVX(invlist);
8465
8466     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8467
8468     /* Must be empty */
8469     assert(! _invlist_len(invlist));
8470
8471     *zero_addr = 0;
8472
8473     /* 1^1 = 0; 1^0 = 1 */
8474     *offset = 1 ^ will_have_0;
8475     return zero_addr + *offset;
8476 }
8477
8478 #endif
8479
8480 PERL_STATIC_INLINE void
8481 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8482 {
8483     /* Sets the current number of elements stored in the inversion list.
8484      * Updates SvCUR correspondingly */
8485     PERL_UNUSED_CONTEXT;
8486     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8487
8488     assert(SvTYPE(invlist) == SVt_INVLIST);
8489
8490     SvCUR_set(invlist,
8491               (len == 0)
8492                ? 0
8493                : TO_INTERNAL_SIZE(len + offset));
8494     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8495 }
8496
8497 #ifndef PERL_IN_XSUB_RE
8498
8499 STATIC void
8500 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8501 {
8502     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
8503      * steals the list from 'src', so 'src' is made to have a NULL list.  This
8504      * is similar to what SvSetMagicSV() would do, if it were implemented on
8505      * inversion lists, though this routine avoids a copy */
8506
8507     const UV src_len          = _invlist_len(src);
8508     const bool src_offset     = *get_invlist_offset_addr(src);
8509     const STRLEN src_byte_len = SvLEN(src);
8510     char * array              = SvPVX(src);
8511
8512     const int oldtainted = TAINT_get;
8513
8514     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8515
8516     assert(SvTYPE(src) == SVt_INVLIST);
8517     assert(SvTYPE(dest) == SVt_INVLIST);
8518     assert(! invlist_is_iterating(src));
8519     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8520
8521     /* Make sure it ends in the right place with a NUL, as our inversion list
8522      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8523      * asserts it */
8524     array[src_byte_len - 1] = '\0';
8525
8526     TAINT_NOT;      /* Otherwise it breaks */
8527     sv_usepvn_flags(dest,
8528                     (char *) array,
8529                     src_byte_len - 1,
8530
8531                     /* This flag is documented to cause a copy to be avoided */
8532                     SV_HAS_TRAILING_NUL);
8533     TAINT_set(oldtainted);
8534     SvPV_set(src, 0);
8535     SvLEN_set(src, 0);
8536     SvCUR_set(src, 0);
8537
8538     /* Finish up copying over the other fields in an inversion list */
8539     *get_invlist_offset_addr(dest) = src_offset;
8540     invlist_set_len(dest, src_len, src_offset);
8541     *get_invlist_previous_index_addr(dest) = 0;
8542     invlist_iterfinish(dest);
8543 }
8544
8545 PERL_STATIC_INLINE IV*
8546 S_get_invlist_previous_index_addr(SV* invlist)
8547 {
8548     /* Return the address of the IV that is reserved to hold the cached index
8549      * */
8550     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8551
8552     assert(SvTYPE(invlist) == SVt_INVLIST);
8553
8554     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8555 }
8556
8557 PERL_STATIC_INLINE IV
8558 S_invlist_previous_index(SV* const invlist)
8559 {
8560     /* Returns cached index of previous search */
8561
8562     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8563
8564     return *get_invlist_previous_index_addr(invlist);
8565 }
8566
8567 PERL_STATIC_INLINE void
8568 S_invlist_set_previous_index(SV* const invlist, const IV index)
8569 {
8570     /* Caches <index> for later retrieval */
8571
8572     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8573
8574     assert(index == 0 || index < (int) _invlist_len(invlist));
8575
8576     *get_invlist_previous_index_addr(invlist) = index;
8577 }
8578
8579 PERL_STATIC_INLINE void
8580 S_invlist_trim(SV* invlist)
8581 {
8582     /* Free the not currently-being-used space in an inversion list */
8583
8584     /* But don't free up the space needed for the 0 UV that is always at the
8585      * beginning of the list, nor the trailing NUL */
8586     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8587
8588     PERL_ARGS_ASSERT_INVLIST_TRIM;
8589
8590     assert(SvTYPE(invlist) == SVt_INVLIST);
8591
8592     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8593 }
8594
8595 PERL_STATIC_INLINE void
8596 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8597 {
8598     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8599
8600     assert(SvTYPE(invlist) == SVt_INVLIST);
8601
8602     invlist_set_len(invlist, 0, 0);
8603     invlist_trim(invlist);
8604 }
8605
8606 #endif /* ifndef PERL_IN_XSUB_RE */
8607
8608 PERL_STATIC_INLINE bool
8609 S_invlist_is_iterating(SV* const invlist)
8610 {
8611     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8612
8613     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8614 }
8615
8616 #ifndef PERL_IN_XSUB_RE
8617
8618 PERL_STATIC_INLINE UV
8619 S_invlist_max(SV* const invlist)
8620 {
8621     /* Returns the maximum number of elements storable in the inversion list's
8622      * array, without having to realloc() */
8623
8624     PERL_ARGS_ASSERT_INVLIST_MAX;
8625
8626     assert(SvTYPE(invlist) == SVt_INVLIST);
8627
8628     /* Assumes worst case, in which the 0 element is not counted in the
8629      * inversion list, so subtracts 1 for that */
8630     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8631            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8632            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8633 }
8634 SV*
8635 Perl__new_invlist(pTHX_ IV initial_size)
8636 {
8637
8638     /* Return a pointer to a newly constructed inversion list, with enough
8639      * space to store 'initial_size' elements.  If that number is negative, a
8640      * system default is used instead */
8641
8642     SV* new_list;
8643
8644     if (initial_size < 0) {
8645         initial_size = 10;
8646     }
8647
8648     /* Allocate the initial space */
8649     new_list = newSV_type(SVt_INVLIST);
8650
8651     /* First 1 is in case the zero element isn't in the list; second 1 is for
8652      * trailing NUL */
8653     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8654     invlist_set_len(new_list, 0, 0);
8655
8656     /* Force iterinit() to be used to get iteration to work */
8657     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8658
8659     *get_invlist_previous_index_addr(new_list) = 0;
8660
8661     return new_list;
8662 }
8663
8664 SV*
8665 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8666 {
8667     /* Return a pointer to a newly constructed inversion list, initialized to
8668      * point to <list>, which has to be in the exact correct inversion list
8669      * form, including internal fields.  Thus this is a dangerous routine that
8670      * should not be used in the wrong hands.  The passed in 'list' contains
8671      * several header fields at the beginning that are not part of the
8672      * inversion list body proper */
8673
8674     const STRLEN length = (STRLEN) list[0];
8675     const UV version_id =          list[1];
8676     const bool offset   =    cBOOL(list[2]);
8677 #define HEADER_LENGTH 3
8678     /* If any of the above changes in any way, you must change HEADER_LENGTH
8679      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8680      *      perl -E 'say int(rand 2**31-1)'
8681      */
8682 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8683                                         data structure type, so that one being
8684                                         passed in can be validated to be an
8685                                         inversion list of the correct vintage.
8686                                        */
8687
8688     SV* invlist = newSV_type(SVt_INVLIST);
8689
8690     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8691
8692     if (version_id != INVLIST_VERSION_ID) {
8693         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8694     }
8695
8696     /* The generated array passed in includes header elements that aren't part
8697      * of the list proper, so start it just after them */
8698     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8699
8700     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8701                                shouldn't touch it */
8702
8703     *(get_invlist_offset_addr(invlist)) = offset;
8704
8705     /* The 'length' passed to us is the physical number of elements in the
8706      * inversion list.  But if there is an offset the logical number is one
8707      * less than that */
8708     invlist_set_len(invlist, length  - offset, offset);
8709
8710     invlist_set_previous_index(invlist, 0);
8711
8712     /* Initialize the iteration pointer. */
8713     invlist_iterfinish(invlist);
8714
8715     SvREADONLY_on(invlist);
8716
8717     return invlist;
8718 }
8719
8720 STATIC void
8721 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8722 {
8723     /* Grow the maximum size of an inversion list */
8724
8725     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8726
8727     assert(SvTYPE(invlist) == SVt_INVLIST);
8728
8729     /* Add one to account for the zero element at the beginning which may not
8730      * be counted by the calling parameters */
8731     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8732 }
8733
8734 STATIC void
8735 S__append_range_to_invlist(pTHX_ SV* const invlist,
8736                                  const UV start, const UV end)
8737 {
8738    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8739     * the end of the inversion list.  The range must be above any existing
8740     * ones. */
8741
8742     UV* array;
8743     UV max = invlist_max(invlist);
8744     UV len = _invlist_len(invlist);
8745     bool offset;
8746
8747     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8748
8749     if (len == 0) { /* Empty lists must be initialized */
8750         offset = start != 0;
8751         array = _invlist_array_init(invlist, ! offset);
8752     }
8753     else {
8754         /* Here, the existing list is non-empty. The current max entry in the
8755          * list is generally the first value not in the set, except when the
8756          * set extends to the end of permissible values, in which case it is
8757          * the first entry in that final set, and so this call is an attempt to
8758          * append out-of-order */
8759
8760         UV final_element = len - 1;
8761         array = invlist_array(invlist);
8762         if (   array[final_element] > start
8763             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8764         {
8765             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",
8766                      array[final_element], start,
8767                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8768         }
8769
8770         /* Here, it is a legal append.  If the new range begins 1 above the end
8771          * of the range below it, it is extending the range below it, so the
8772          * new first value not in the set is one greater than the newly
8773          * extended range.  */
8774         offset = *get_invlist_offset_addr(invlist);
8775         if (array[final_element] == start) {
8776             if (end != UV_MAX) {
8777                 array[final_element] = end + 1;
8778             }
8779             else {
8780                 /* But if the end is the maximum representable on the machine,
8781                  * assume that infinity was actually what was meant.  Just let
8782                  * the range that this would extend to have no end */
8783                 invlist_set_len(invlist, len - 1, offset);
8784             }
8785             return;
8786         }
8787     }
8788
8789     /* Here the new range doesn't extend any existing set.  Add it */
8790
8791     len += 2;   /* Includes an element each for the start and end of range */
8792
8793     /* If wll overflow the existing space, extend, which may cause the array to
8794      * be moved */
8795     if (max < len) {
8796         invlist_extend(invlist, len);
8797
8798         /* Have to set len here to avoid assert failure in invlist_array() */
8799         invlist_set_len(invlist, len, offset);
8800
8801         array = invlist_array(invlist);
8802     }
8803     else {
8804         invlist_set_len(invlist, len, offset);
8805     }
8806
8807     /* The next item on the list starts the range, the one after that is
8808      * one past the new range.  */
8809     array[len - 2] = start;
8810     if (end != UV_MAX) {
8811         array[len - 1] = end + 1;
8812     }
8813     else {
8814         /* But if the end is the maximum representable on the machine, just let
8815          * the range have no end */
8816         invlist_set_len(invlist, len - 1, offset);
8817     }
8818 }
8819
8820 SSize_t
8821 Perl__invlist_search(SV* const invlist, const UV cp)
8822 {
8823     /* Searches the inversion list for the entry that contains the input code
8824      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8825      * return value is the index into the list's array of the range that
8826      * contains <cp>, that is, 'i' such that
8827      *  array[i] <= cp < array[i+1]
8828      */
8829
8830     IV low = 0;
8831     IV mid;
8832     IV high = _invlist_len(invlist);
8833     const IV highest_element = high - 1;
8834     const UV* array;
8835
8836     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8837
8838     /* If list is empty, return failure. */
8839     if (high == 0) {
8840         return -1;
8841     }
8842
8843     /* (We can't get the array unless we know the list is non-empty) */
8844     array = invlist_array(invlist);
8845
8846     mid = invlist_previous_index(invlist);
8847     assert(mid >=0);
8848     if (mid > highest_element) {
8849         mid = highest_element;
8850     }
8851
8852     /* <mid> contains the cache of the result of the previous call to this
8853      * function (0 the first time).  See if this call is for the same result,
8854      * or if it is for mid-1.  This is under the theory that calls to this
8855      * function will often be for related code points that are near each other.
8856      * And benchmarks show that caching gives better results.  We also test
8857      * here if the code point is within the bounds of the list.  These tests
8858      * replace others that would have had to be made anyway to make sure that
8859      * the array bounds were not exceeded, and these give us extra information
8860      * at the same time */
8861     if (cp >= array[mid]) {
8862         if (cp >= array[highest_element]) {
8863             return highest_element;
8864         }
8865
8866         /* Here, array[mid] <= cp < array[highest_element].  This means that
8867          * the final element is not the answer, so can exclude it; it also
8868          * means that <mid> is not the final element, so can refer to 'mid + 1'
8869          * safely */
8870         if (cp < array[mid + 1]) {
8871             return mid;
8872         }
8873         high--;
8874         low = mid + 1;
8875     }
8876     else { /* cp < aray[mid] */
8877         if (cp < array[0]) { /* Fail if outside the array */
8878             return -1;
8879         }
8880         high = mid;
8881         if (cp >= array[mid - 1]) {
8882             goto found_entry;
8883         }
8884     }
8885
8886     /* Binary search.  What we are looking for is <i> such that
8887      *  array[i] <= cp < array[i+1]
8888      * The loop below converges on the i+1.  Note that there may not be an
8889      * (i+1)th element in the array, and things work nonetheless */
8890     while (low < high) {
8891         mid = (low + high) / 2;
8892         assert(mid <= highest_element);
8893         if (array[mid] <= cp) { /* cp >= array[mid] */
8894             low = mid + 1;
8895
8896             /* We could do this extra test to exit the loop early.
8897             if (cp < array[low]) {
8898                 return mid;
8899             }
8900             */
8901         }
8902         else { /* cp < array[mid] */
8903             high = mid;
8904         }
8905     }
8906
8907   found_entry:
8908     high--;
8909     invlist_set_previous_index(invlist, high);
8910     return high;
8911 }
8912
8913 void
8914 Perl__invlist_populate_swatch(SV* const invlist,
8915                               const UV start, const UV end, U8* swatch)
8916 {
8917     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8918      * but is used when the swash has an inversion list.  This makes this much
8919      * faster, as it uses a binary search instead of a linear one.  This is
8920      * intimately tied to that function, and perhaps should be in utf8.c,
8921      * except it is intimately tied to inversion lists as well.  It assumes
8922      * that <swatch> is all 0's on input */
8923
8924     UV current = start;
8925     const IV len = _invlist_len(invlist);
8926     IV i;
8927     const UV * array;
8928
8929     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8930
8931     if (len == 0) { /* Empty inversion list */
8932         return;
8933     }
8934
8935     array = invlist_array(invlist);
8936
8937     /* Find which element it is */
8938     i = _invlist_search(invlist, start);
8939
8940     /* We populate from <start> to <end> */
8941     while (current < end) {
8942         UV upper;
8943
8944         /* The inversion list gives the results for every possible code point
8945          * after the first one in the list.  Only those ranges whose index is
8946          * even are ones that the inversion list matches.  For the odd ones,
8947          * and if the initial code point is not in the list, we have to skip
8948          * forward to the next element */
8949         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8950             i++;
8951             if (i >= len) { /* Finished if beyond the end of the array */
8952                 return;
8953             }
8954             current = array[i];
8955             if (current >= end) {   /* Finished if beyond the end of what we
8956                                        are populating */
8957                 if (LIKELY(end < UV_MAX)) {
8958                     return;
8959                 }
8960
8961                 /* We get here when the upper bound is the maximum
8962                  * representable on the machine, and we are looking for just
8963                  * that code point.  Have to special case it */
8964                 i = len;
8965                 goto join_end_of_list;
8966             }
8967         }
8968         assert(current >= start);
8969
8970         /* The current range ends one below the next one, except don't go past
8971          * <end> */
8972         i++;
8973         upper = (i < len && array[i] < end) ? array[i] : end;
8974
8975         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8976          * for each code point in it */
8977         for (; current < upper; current++) {
8978             const STRLEN offset = (STRLEN)(current - start);
8979             swatch[offset >> 3] |= 1 << (offset & 7);
8980         }
8981
8982       join_end_of_list:
8983
8984         /* Quit if at the end of the list */
8985         if (i >= len) {
8986
8987             /* But first, have to deal with the highest possible code point on
8988              * the platform.  The previous code assumes that <end> is one
8989              * beyond where we want to populate, but that is impossible at the
8990              * platform's infinity, so have to handle it specially */
8991             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8992             {
8993                 const STRLEN offset = (STRLEN)(end - start);
8994                 swatch[offset >> 3] |= 1 << (offset & 7);
8995             }
8996             return;
8997         }
8998
8999         /* Advance to the next range, which will be for code points not in the
9000          * inversion list */
9001         current = array[i];
9002     }
9003
9004     return;
9005 }
9006
9007 void
9008 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9009                                          const bool complement_b, SV** output)
9010 {
9011     /* Take the union of two inversion lists and point '*output' to it.  On
9012      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9013      * even 'a' or 'b').  If to an inversion list, the contents of the original
9014      * list will be replaced by the union.  The first list, 'a', may be
9015      * NULL, in which case a copy of the second list is placed in '*output'.
9016      * If 'complement_b' is TRUE, the union is taken of the complement
9017      * (inversion) of 'b' instead of b itself.
9018      *
9019      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9020      * Richard Gillam, published by Addison-Wesley, and explained at some
9021      * length there.  The preface says to incorporate its examples into your
9022      * code at your own risk.
9023      *
9024      * The algorithm is like a merge sort. */
9025
9026     const UV* array_a;    /* a's array */
9027     const UV* array_b;
9028     UV len_a;       /* length of a's array */
9029     UV len_b;
9030
9031     SV* u;                      /* the resulting union */
9032     UV* array_u;
9033     UV len_u = 0;
9034
9035     UV i_a = 0;             /* current index into a's array */
9036     UV i_b = 0;
9037     UV i_u = 0;
9038
9039     /* running count, as explained in the algorithm source book; items are
9040      * stopped accumulating and are output when the count changes to/from 0.
9041      * The count is incremented when we start a range that's in an input's set,
9042      * and decremented when we start a range that's not in a set.  So this
9043      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9044      * and hence nothing goes into the union; 1, just one of the inputs is in
9045      * its set (and its current range gets added to the union); and 2 when both
9046      * inputs are in their sets.  */
9047     UV count = 0;
9048
9049     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9050     assert(a != b);
9051     assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
9052
9053     len_b = _invlist_len(b);
9054     if (len_b == 0) {
9055
9056         /* Here, 'b' is empty, hence it's complement is all possible code
9057          * points.  So if the union includes the complement of 'b', it includes
9058          * everything, and we need not even look at 'a'.  It's easiest to
9059          * create a new inversion list that matches everything.  */
9060         if (complement_b) {
9061             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9062
9063             if (*output == NULL) { /* If the output didn't exist, just point it
9064                                       at the new list */
9065                 *output = everything;
9066             }
9067             else { /* Otherwise, replace its contents with the new list */
9068                 invlist_replace_list_destroys_src(*output, everything);
9069                 SvREFCNT_dec_NN(everything);
9070             }
9071
9072             return;
9073         }
9074
9075         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9076          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9077          * output will be empty */
9078
9079         if (a == NULL || _invlist_len(a) == 0) {
9080             if (*output == NULL) {
9081                 *output = _new_invlist(0);
9082             }
9083             else {
9084                 invlist_clear(*output);
9085             }
9086             return;
9087         }
9088
9089         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9090          * union.  We can just return a copy of 'a' if '*output' doesn't point
9091          * to an existing list */
9092         if (*output == NULL) {
9093             *output = invlist_clone(a);
9094             return;
9095         }
9096
9097         /* If the output is to overwrite 'a', we have a no-op, as it's
9098          * already in 'a' */
9099         if (*output == a) {
9100             return;
9101         }
9102
9103         /* Here, '*output' is to be overwritten by 'a' */
9104         u = invlist_clone(a);
9105         invlist_replace_list_destroys_src(*output, u);
9106         SvREFCNT_dec_NN(u);
9107
9108         return;
9109     }
9110
9111     /* Here 'b' is not empty.  See about 'a' */
9112
9113     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9114
9115         /* Here, 'a' is empty (and b is not).  That means the union will come
9116          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9117          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9118          * the clone */
9119
9120         SV ** dest = (*output == NULL) ? output : &u;
9121         *dest = invlist_clone(b);
9122         if (complement_b) {
9123             _invlist_invert(*dest);
9124         }
9125
9126         if (dest == &u) {
9127             invlist_replace_list_destroys_src(*output, u);
9128             SvREFCNT_dec_NN(u);
9129         }
9130
9131         return;
9132     }
9133
9134     /* Here both lists exist and are non-empty */
9135     array_a = invlist_array(a);
9136     array_b = invlist_array(b);
9137
9138     /* If are to take the union of 'a' with the complement of b, set it
9139      * up so are looking at b's complement. */
9140     if (complement_b) {
9141
9142         /* To complement, we invert: if the first element is 0, remove it.  To
9143          * do this, we just pretend the array starts one later */
9144         if (array_b[0] == 0) {
9145             array_b++;
9146             len_b--;
9147         }
9148         else {
9149
9150             /* But if the first element is not zero, we pretend the list starts
9151              * at the 0 that is always stored immediately before the array. */
9152             array_b--;
9153             len_b++;
9154         }
9155     }
9156
9157     /* Size the union for the worst case: that the sets are completely
9158      * disjoint */
9159     u = _new_invlist(len_a + len_b);
9160
9161     /* Will contain U+0000 if either component does */
9162     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9163                                       || (len_b > 0 && array_b[0] == 0));
9164
9165     /* Go through each input list item by item, stopping when have exhausted
9166      * one of them */
9167     while (i_a < len_a && i_b < len_b) {
9168         UV cp;      /* The element to potentially add to the union's array */
9169         bool cp_in_set;   /* is it in the the input list's set or not */
9170
9171         /* We need to take one or the other of the two inputs for the union.
9172          * Since we are merging two sorted lists, we take the smaller of the
9173          * next items.  In case of a tie, we take first the one that is in its
9174          * set.  If we first took the one not in its set, it would decrement
9175          * the count, possibly to 0 which would cause it to be output as ending
9176          * the range, and the next time through we would take the same number,
9177          * and output it again as beginning the next range.  By doing it the
9178          * opposite way, there is no possibility that the count will be
9179          * momentarily decremented to 0, and thus the two adjoining ranges will
9180          * be seamlessly merged.  (In a tie and both are in the set or both not
9181          * in the set, it doesn't matter which we take first.) */
9182         if (       array_a[i_a] < array_b[i_b]
9183             || (   array_a[i_a] == array_b[i_b]
9184                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9185         {
9186             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9187             cp = array_a[i_a++];
9188         }
9189         else {
9190             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9191             cp = array_b[i_b++];
9192         }
9193
9194         /* Here, have chosen which of the two inputs to look at.  Only output
9195          * if the running count changes to/from 0, which marks the
9196          * beginning/end of a range that's in the set */
9197         if (cp_in_set) {
9198             if (count == 0) {
9199                 array_u[i_u++] = cp;
9200             }
9201             count++;
9202         }
9203         else {
9204             count--;
9205             if (count == 0) {
9206                 array_u[i_u++] = cp;
9207             }
9208         }
9209     }
9210
9211
9212     /* The loop above increments the index into exactly one of the input lists
9213      * each iteration, and ends when either index gets to its list end.  That
9214      * means the other index is lower than its end, and so something is
9215      * remaining in that one.  We decrement 'count', as explained below, if
9216      * that list is in its set.  (i_a and i_b each currently index the element
9217      * beyond the one we care about.) */
9218     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9219         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9220     {
9221         count--;
9222     }
9223
9224     /* Above we decremented 'count' if the list that had unexamined elements in
9225      * it was in its set.  This has made it so that 'count' being non-zero
9226      * means there isn't anything left to output; and 'count' equal to 0 means
9227      * that what is left to output is precisely that which is left in the
9228      * non-exhausted input list.
9229      *
9230      * To see why, note first that the exhausted input obviously has nothing
9231      * left to add to the union.  If it was in its set at its end, that means
9232      * the set extends from here to the platform's infinity, and hence so does
9233      * the union and the non-exhausted set is irrelevant.  The exhausted set
9234      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9235      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9236      * 'count' remains at 1.  This is consistent with the decremented 'count'
9237      * != 0 meaning there's nothing left to add to the union.
9238      *
9239      * But if the exhausted input wasn't in its set, it contributed 0 to
9240      * 'count', and the rest of the union will be whatever the other input is.
9241      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9242      * otherwise it gets decremented to 0.  This is consistent with 'count'
9243      * == 0 meaning the remainder of the union is whatever is left in the
9244      * non-exhausted list. */
9245     if (count != 0) {
9246         len_u = i_u;
9247     }
9248     else {
9249         IV copy_count = len_a - i_a;
9250         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9251             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9252         }
9253         else { /* The non-exhausted input is b */
9254             copy_count = len_b - i_b;
9255             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9256         }
9257         len_u = i_u + copy_count;
9258     }
9259
9260     /* Set the result to the final length, which can change the pointer to
9261      * array_u, so re-find it.  (Note that it is unlikely that this will
9262      * change, as we are shrinking the space, not enlarging it) */
9263     if (len_u != _invlist_len(u)) {
9264         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9265         invlist_trim(u);
9266         array_u = invlist_array(u);
9267     }
9268
9269     if (*output == NULL) {  /* Simply return the new inversion list */
9270         *output = u;
9271     }
9272     else {
9273         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9274          * could instead free '*output', and then set it to 'u', but experience
9275          * has shown [perl #127392] that if the input is a mortal, we can get a
9276          * huge build-up of these during regex compilation before they get
9277          * freed. */
9278         invlist_replace_list_destroys_src(*output, u);
9279         SvREFCNT_dec_NN(u);
9280     }
9281
9282     return;
9283 }
9284
9285 void
9286 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9287                                                const bool complement_b, SV** i)
9288 {
9289     /* Take the intersection of two inversion lists and point '*i' to it.  On
9290      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9291      * even 'a' or 'b').  If to an inversion list, the contents of the original
9292      * list will be replaced by the intersection.  The first list, 'a', may be
9293      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9294      * TRUE, the result will be the intersection of 'a' and the complement (or
9295      * inversion) of 'b' instead of 'b' directly.
9296      *
9297      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9298      * Richard Gillam, published by Addison-Wesley, and explained at some
9299      * length there.  The preface says to incorporate its examples into your
9300      * code at your own risk.  In fact, it had bugs
9301      *
9302      * The algorithm is like a merge sort, and is essentially the same as the
9303      * union above
9304      */
9305
9306     const UV* array_a;          /* a's array */
9307     const UV* array_b;
9308     UV len_a;   /* length of a's array */
9309     UV len_b;
9310
9311     SV* r;                   /* the resulting intersection */
9312     UV* array_r;
9313     UV len_r = 0;
9314
9315     UV i_a = 0;             /* current index into a's array */
9316     UV i_b = 0;
9317     UV i_r = 0;
9318
9319     /* running count of how many of the two inputs are postitioned at ranges
9320      * that are in their sets.  As explained in the algorithm source book,
9321      * items are stopped accumulating and are output when the count changes
9322      * to/from 2.  The count is incremented when we start a range that's in an
9323      * input's set, and decremented when we start a range that's not in a set.
9324      * Only when it is 2 are we in the intersection. */
9325     UV count = 0;
9326
9327     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9328     assert(a != b);
9329     assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
9330
9331     /* Special case if either one is empty */
9332     len_a = (a == NULL) ? 0 : _invlist_len(a);
9333     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9334         if (len_a != 0 && complement_b) {
9335
9336             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9337              * must be empty.  Here, also we are using 'b's complement, which
9338              * hence must be every possible code point.  Thus the intersection
9339              * is simply 'a'. */
9340
9341             if (*i == a) {  /* No-op */
9342                 return;
9343             }
9344
9345             if (*i == NULL) {
9346                 *i = invlist_clone(a);
9347                 return;
9348             }
9349
9350             r = invlist_clone(a);
9351             invlist_replace_list_destroys_src(*i, r);
9352             SvREFCNT_dec_NN(r);
9353             return;
9354         }
9355
9356         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9357          * intersection must be empty */
9358         if (*i == NULL) {
9359             *i = _new_invlist(0);
9360             return;
9361         }
9362
9363         invlist_clear(*i);
9364         return;
9365     }
9366
9367     /* Here both lists exist and are non-empty */
9368     array_a = invlist_array(a);
9369     array_b = invlist_array(b);
9370
9371     /* If are to take the intersection of 'a' with the complement of b, set it
9372      * up so are looking at b's complement. */
9373     if (complement_b) {
9374
9375         /* To complement, we invert: if the first element is 0, remove it.  To
9376          * do this, we just pretend the array starts one later */
9377         if (array_b[0] == 0) {
9378             array_b++;
9379             len_b--;
9380         }
9381         else {
9382
9383             /* But if the first element is not zero, we pretend the list starts
9384              * at the 0 that is always stored immediately before the array. */
9385             array_b--;
9386             len_b++;
9387         }
9388     }
9389
9390     /* Size the intersection for the worst case: that the intersection ends up
9391      * fragmenting everything to be completely disjoint */
9392     r= _new_invlist(len_a + len_b);
9393
9394     /* Will contain U+0000 iff both components do */
9395     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9396                                      && len_b > 0 && array_b[0] == 0);
9397
9398     /* Go through each list item by item, stopping when have exhausted one of
9399      * them */
9400     while (i_a < len_a && i_b < len_b) {
9401         UV cp;      /* The element to potentially add to the intersection's
9402                        array */
9403         bool cp_in_set; /* Is it in the input list's set or not */
9404
9405         /* We need to take one or the other of the two inputs for the
9406          * intersection.  Since we are merging two sorted lists, we take the
9407          * smaller of the next items.  In case of a tie, we take first the one
9408          * that is not in its set (a difference from the union algorithm).  If
9409          * we first took the one in its set, it would increment the count,
9410          * possibly to 2 which would cause it to be output as starting a range
9411          * in the intersection, and the next time through we would take that
9412          * same number, and output it again as ending the set.  By doing the
9413          * opposite of this, there is no possibility that the count will be
9414          * momentarily incremented to 2.  (In a tie and both are in the set or
9415          * both not in the set, it doesn't matter which we take first.) */
9416         if (       array_a[i_a] < array_b[i_b]
9417             || (   array_a[i_a] == array_b[i_b]
9418                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9419         {
9420             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9421             cp = array_a[i_a++];
9422         }
9423         else {
9424             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9425             cp= array_b[i_b++];
9426         }
9427
9428         /* Here, have chosen which of the two inputs to look at.  Only output
9429          * if the running count changes to/from 2, which marks the
9430          * beginning/end of a range that's in the intersection */
9431         if (cp_in_set) {
9432             count++;
9433             if (count == 2) {
9434                 array_r[i_r++] = cp;
9435             }
9436         }
9437         else {
9438             if (count == 2) {
9439                 array_r[i_r++] = cp;
9440             }
9441             count--;
9442         }
9443
9444     }
9445
9446     /* The loop above increments the index into exactly one of the input lists
9447      * each iteration, and ends when either index gets to its list end.  That
9448      * means the other index is lower than its end, and so something is
9449      * remaining in that one.  We increment 'count', as explained below, if the
9450      * exhausted list was in its set.  (i_a and i_b each currently index the
9451      * element beyond the one we care about.) */
9452     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9453         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9454     {
9455         count++;
9456     }
9457
9458     /* Above we incremented 'count' if the exhausted list was in its set.  This
9459      * has made it so that 'count' being below 2 means there is nothing left to
9460      * output; otheriwse what's left to add to the intersection is precisely
9461      * that which is left in the non-exhausted input list.
9462      *
9463      * To see why, note first that the exhausted input obviously has nothing
9464      * left to affect the intersection.  If it was in its set at its end, that
9465      * means the set extends from here to the platform's infinity, and hence
9466      * anything in the non-exhausted's list will be in the intersection, and
9467      * anything not in it won't be.  Hence, the rest of the intersection is
9468      * precisely what's in the non-exhausted list  The exhausted set also
9469      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9470      * it means 'count' is now at least 2.  This is consistent with the
9471      * incremented 'count' being >= 2 means to add the non-exhausted list to
9472      * the intersection.
9473      *
9474      * But if the exhausted input wasn't in its set, it contributed 0 to
9475      * 'count', and the intersection can't include anything further; the
9476      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9477      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9478      * further to add to the intersection. */
9479     if (count < 2) { /* Nothing left to put in the intersection. */
9480         len_r = i_r;
9481     }
9482     else { /* copy the non-exhausted list, unchanged. */
9483         IV copy_count = len_a - i_a;
9484         if (copy_count > 0) {   /* a is the one with stuff left */
9485             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9486         }
9487         else {  /* b is the one with stuff left */
9488             copy_count = len_b - i_b;
9489             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9490         }
9491         len_r = i_r + copy_count;
9492     }
9493
9494     /* Set the result to the final length, which can change the pointer to
9495      * array_r, so re-find it.  (Note that it is unlikely that this will
9496      * change, as we are shrinking the space, not enlarging it) */
9497     if (len_r != _invlist_len(r)) {
9498         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9499         invlist_trim(r);
9500         array_r = invlist_array(r);
9501     }
9502
9503     if (*i == NULL) { /* Simply return the calculated intersection */
9504         *i = r;
9505     }
9506     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9507               instead free '*i', and then set it to 'r', but experience has
9508               shown [perl #127392] that if the input is a mortal, we can get a
9509               huge build-up of these during regex compilation before they get
9510               freed. */
9511         if (len_r) {
9512             invlist_replace_list_destroys_src(*i, r);
9513         }
9514         else {
9515             invlist_clear(*i);
9516         }
9517         SvREFCNT_dec_NN(r);
9518     }
9519
9520     return;
9521 }
9522
9523 SV*
9524 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9525 {
9526     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9527      * set.  A pointer to the inversion list is returned.  This may actually be
9528      * a new list, in which case the passed in one has been destroyed.  The
9529      * passed-in inversion list can be NULL, in which case a new one is created
9530      * with just the one range in it.  The new list is not necessarily
9531      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9532      * result of this function.  The gain would not be large, and in many
9533      * cases, this is called multiple times on a single inversion list, so
9534      * anything freed may almost immediately be needed again.
9535      *
9536      * This used to mostly call the 'union' routine, but that is much more
9537      * heavyweight than really needed for a single range addition */
9538
9539     UV* array;              /* The array implementing the inversion list */
9540     UV len;                 /* How many elements in 'array' */
9541     SSize_t i_s;            /* index into the invlist array where 'start'
9542                                should go */
9543     SSize_t i_e = 0;        /* And the index where 'end' should go */
9544     UV cur_highest;         /* The highest code point in the inversion list
9545                                upon entry to this function */
9546
9547     /* This range becomes the whole inversion list if none already existed */
9548     if (invlist == NULL) {
9549         invlist = _new_invlist(2);
9550         _append_range_to_invlist(invlist, start, end);
9551         return invlist;
9552     }
9553
9554     /* Likewise, if the inversion list is currently empty */
9555     len = _invlist_len(invlist);
9556     if (len == 0) {
9557         _append_range_to_invlist(invlist, start, end);
9558         return invlist;
9559     }
9560
9561     /* Starting here, we have to know the internals of the list */
9562     array = invlist_array(invlist);
9563
9564     /* If the new range ends higher than the current highest ... */
9565     cur_highest = invlist_highest(invlist);
9566     if (end > cur_highest) {
9567
9568         /* If the whole range is higher, we can just append it */
9569         if (start > cur_highest) {
9570             _append_range_to_invlist(invlist, start, end);
9571             return invlist;
9572         }
9573
9574         /* Otherwise, add the portion that is higher ... */
9575         _append_range_to_invlist(invlist, cur_highest + 1, end);
9576
9577         /* ... and continue on below to handle the rest.  As a result of the
9578          * above append, we know that the index of the end of the range is the
9579          * final even numbered one of the array.  Recall that the final element
9580          * always starts a range that extends to infinity.  If that range is in
9581          * the set (meaning the set goes from here to infinity), it will be an
9582          * even index, but if it isn't in the set, it's odd, and the final
9583          * range in the set is one less, which is even. */
9584         if (end == UV_MAX) {
9585             i_e = len;
9586         }
9587         else {
9588             i_e = len - 2;
9589         }
9590     }
9591
9592     /* We have dealt with appending, now see about prepending.  If the new
9593      * range starts lower than the current lowest ... */
9594     if (start < array[0]) {
9595
9596         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
9597          * Let the union code handle it, rather than having to know the
9598          * trickiness in two code places.  */
9599         if (UNLIKELY(start == 0)) {
9600             SV* range_invlist;
9601
9602             range_invlist = _new_invlist(2);
9603             _append_range_to_invlist(range_invlist, start, end);
9604
9605             _invlist_union(invlist, range_invlist, &invlist);
9606
9607             SvREFCNT_dec_NN(range_invlist);
9608
9609             return invlist;
9610         }
9611
9612         /* If the whole new range comes before the first entry, and doesn't
9613          * extend it, we have to insert it as an additional range */
9614         if (end < array[0] - 1) {
9615             i_s = i_e = -1;
9616             goto splice_in_new_range;
9617         }
9618
9619         /* Here the new range adjoins the existing first range, extending it
9620          * downwards. */
9621         array[0] = start;
9622
9623         /* And continue on below to handle the rest.  We know that the index of
9624          * the beginning of the range is the first one of the array */
9625         i_s = 0;
9626     }
9627     else { /* Not prepending any part of the new range to the existing list.
9628             * Find where in the list it should go.  This finds i_s, such that:
9629             *     invlist[i_s] <= start < array[i_s+1]
9630             */
9631         i_s = _invlist_search(invlist, start);
9632     }
9633
9634     /* At this point, any extending before the beginning of the inversion list
9635      * and/or after the end has been done.  This has made it so that, in the
9636      * code below, each endpoint of the new range is either in a range that is
9637      * in the set, or is in a gap between two ranges that are.  This means we
9638      * don't have to worry about exceeding the array bounds.
9639      *
9640      * Find where in the list the new range ends (but we can skip this if we
9641      * have already determined what it is, or if it will be the same as i_s,
9642      * which we already have computed) */
9643     if (i_e == 0) {
9644         i_e = (start == end)
9645               ? i_s
9646               : _invlist_search(invlist, end);
9647     }
9648
9649     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
9650      * is a range that goes to infinity there is no element at invlist[i_e+1],
9651      * so only the first relation holds. */
9652
9653     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9654
9655         /* Here, the ranges on either side of the beginning of the new range
9656          * are in the set, and this range starts in the gap between them.
9657          *
9658          * The new range extends the range above it downwards if the new range
9659          * ends at or above that range's start */
9660         const bool extends_the_range_above = (   end == UV_MAX
9661                                               || end + 1 >= array[i_s+1]);
9662
9663         /* The new range extends the range below it upwards if it begins just
9664          * after where that range ends */
9665         if (start == array[i_s]) {
9666
9667             /* If the new range fills the entire gap between the other ranges,
9668              * they will get merged together.  Other ranges may also get
9669              * merged, depending on how many of them the new range spans.  In
9670              * the general case, we do the merge later, just once, after we
9671              * figure out how many to merge.  But in the case where the new
9672              * range exactly spans just this one gap (possibly extending into
9673              * the one above), we do the merge here, and an early exit.  This
9674              * is done here to avoid having to special case later. */
9675             if (i_e - i_s <= 1) {
9676
9677                 /* If i_e - i_s == 1, it means that the new range terminates
9678                  * within the range above, and hence 'extends_the_range_above'
9679                  * must be true.  (If the range above it extends to infinity,
9680                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
9681                  * will be 0, so no harm done.) */
9682                 if (extends_the_range_above) {
9683                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
9684                     invlist_set_len(invlist,
9685                                     len - 2,
9686                                     *(get_invlist_offset_addr(invlist)));
9687                     return invlist;
9688                 }
9689
9690                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
9691                  * to the same range, and below we are about to decrement i_s
9692                  * */
9693                 i_e--;
9694             }
9695
9696             /* Here, the new range is adjacent to the one below.  (It may also
9697              * span beyond the range above, but that will get resolved later.)
9698              * Extend the range below to include this one. */
9699             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
9700             i_s--;
9701             start = array[i_s];
9702         }
9703         else if (extends_the_range_above) {
9704
9705             /* Here the new range only extends the range above it, but not the
9706              * one below.  It merges with the one above.  Again, we keep i_e
9707              * and i_s in sync if they point to the same range */
9708             if (i_e == i_s) {
9709                 i_e++;
9710             }
9711             i_s++;
9712             array[i_s] = start;
9713         }
9714     }
9715
9716     /* Here, we've dealt with the new range start extending any adjoining
9717      * existing ranges.
9718      *
9719      * If the new range extends to infinity, it is now the final one,
9720      * regardless of what was there before */
9721     if (UNLIKELY(end == UV_MAX)) {
9722         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
9723         return invlist;
9724     }
9725
9726     /* If i_e started as == i_s, it has also been dealt with,
9727      * and been updated to the new i_s, which will fail the following if */
9728     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
9729
9730         /* Here, the ranges on either side of the end of the new range are in
9731          * the set, and this range ends in the gap between them.
9732          *
9733          * If this range is adjacent to (hence extends) the range above it, it
9734          * becomes part of that range; likewise if it extends the range below,
9735          * it becomes part of that range */
9736         if (end + 1 == array[i_e+1]) {
9737             i_e++;
9738             array[i_e] = start;
9739         }
9740         else if (start <= array[i_e]) {
9741             array[i_e] = end + 1;
9742             i_e--;
9743         }
9744     }
9745
9746     if (i_s == i_e) {
9747
9748         /* If the range fits entirely in an existing range (as possibly already
9749          * extended above), it doesn't add anything new */
9750         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9751             return invlist;
9752         }
9753
9754         /* Here, no part of the range is in the list.  Must add it.  It will
9755          * occupy 2 more slots */
9756       splice_in_new_range:
9757
9758         invlist_extend(invlist, len + 2);
9759         array = invlist_array(invlist);
9760         /* Move the rest of the array down two slots. Don't include any
9761          * trailing NUL */
9762         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
9763
9764         /* Do the actual splice */
9765         array[i_e+1] = start;
9766         array[i_e+2] = end + 1;
9767         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
9768         return invlist;
9769     }
9770
9771     /* Here the new range crossed the boundaries of a pre-existing range.  The
9772      * code above has adjusted things so that both ends are in ranges that are
9773      * in the set.  This means everything in between must also be in the set.
9774      * Just squash things together */
9775     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
9776     invlist_set_len(invlist,
9777                     len - i_e + i_s,
9778                     *(get_invlist_offset_addr(invlist)));
9779
9780     return invlist;
9781 }
9782
9783 SV*
9784 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9785                                  UV** other_elements_ptr)
9786 {
9787     /* Create and return an inversion list whose contents are to be populated
9788      * by the caller.  The caller gives the number of elements (in 'size') and
9789      * the very first element ('element0').  This function will set
9790      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9791      * are to be placed.
9792      *
9793      * Obviously there is some trust involved that the caller will properly
9794      * fill in the other elements of the array.
9795      *
9796      * (The first element needs to be passed in, as the underlying code does
9797      * things differently depending on whether it is zero or non-zero) */
9798
9799     SV* invlist = _new_invlist(size);
9800     bool offset;
9801
9802     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9803
9804     invlist = add_cp_to_invlist(invlist, element0);
9805     offset = *get_invlist_offset_addr(invlist);
9806
9807     invlist_set_len(invlist, size, offset);
9808     *other_elements_ptr = invlist_array(invlist) + 1;
9809     return invlist;
9810 }
9811
9812 #endif
9813
9814 PERL_STATIC_INLINE SV*
9815 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9816     return _add_range_to_invlist(invlist, cp, cp);
9817 }
9818
9819 #ifndef PERL_IN_XSUB_RE
9820 void
9821 Perl__invlist_invert(pTHX_ SV* const invlist)
9822 {
9823     /* Complement the input inversion list.  This adds a 0 if the list didn't
9824      * have a zero; removes it otherwise.  As described above, the data
9825      * structure is set up so that this is very efficient */
9826
9827     PERL_ARGS_ASSERT__INVLIST_INVERT;
9828
9829     assert(! invlist_is_iterating(invlist));
9830
9831     /* The inverse of matching nothing is matching everything */
9832     if (_invlist_len(invlist) == 0) {
9833         _append_range_to_invlist(invlist, 0, UV_MAX);
9834         return;
9835     }
9836
9837     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9838 }
9839
9840 #endif
9841
9842 PERL_STATIC_INLINE SV*
9843 S_invlist_clone(pTHX_ SV* const invlist)
9844 {
9845
9846     /* Return a new inversion list that is a copy of the input one, which is
9847      * unchanged.  The new list will not be mortal even if the old one was. */
9848
9849     /* Need to allocate extra space to accommodate Perl's addition of a
9850      * trailing NUL to SvPV's, since it thinks they are always strings */
9851     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9852     STRLEN physical_length = SvCUR(invlist);
9853     bool offset = *(get_invlist_offset_addr(invlist));
9854
9855     PERL_ARGS_ASSERT_INVLIST_CLONE;
9856
9857     *(get_invlist_offset_addr(new_invlist)) = offset;
9858     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9859     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9860
9861     return new_invlist;
9862 }
9863
9864 PERL_STATIC_INLINE STRLEN*
9865 S_get_invlist_iter_addr(SV* invlist)
9866 {
9867     /* Return the address of the UV that contains the current iteration
9868      * position */
9869
9870     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9871
9872     assert(SvTYPE(invlist) == SVt_INVLIST);
9873
9874     return &(((XINVLIST*) SvANY(invlist))->iterator);
9875 }
9876
9877 PERL_STATIC_INLINE void
9878 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9879 {
9880     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9881
9882     *get_invlist_iter_addr(invlist) = 0;
9883 }
9884
9885 PERL_STATIC_INLINE void
9886 S_invlist_iterfinish(SV* invlist)
9887 {
9888     /* Terminate iterator for invlist.  This is to catch development errors.
9889      * Any iteration that is interrupted before completed should call this
9890      * function.  Functions that add code points anywhere else but to the end
9891      * of an inversion list assert that they are not in the middle of an
9892      * iteration.  If they were, the addition would make the iteration
9893      * problematical: if the iteration hadn't reached the place where things
9894      * were being added, it would be ok */
9895
9896     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9897
9898     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9899 }
9900
9901 STATIC bool
9902 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9903 {
9904     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9905      * This call sets in <*start> and <*end>, the next range in <invlist>.
9906      * Returns <TRUE> if successful and the next call will return the next
9907      * range; <FALSE> if was already at the end of the list.  If the latter,
9908      * <*start> and <*end> are unchanged, and the next call to this function
9909      * will start over at the beginning of the list */
9910
9911     STRLEN* pos = get_invlist_iter_addr(invlist);
9912     UV len = _invlist_len(invlist);
9913     UV *array;
9914
9915     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9916
9917     if (*pos >= len) {
9918         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9919         return FALSE;
9920     }
9921
9922     array = invlist_array(invlist);
9923
9924     *start = array[(*pos)++];
9925
9926     if (*pos >= len) {
9927         *end = UV_MAX;
9928     }
9929     else {
9930         *end = array[(*pos)++] - 1;
9931     }
9932
9933     return TRUE;
9934 }
9935
9936 PERL_STATIC_INLINE UV
9937 S_invlist_highest(SV* const invlist)
9938 {
9939     /* Returns the highest code point that matches an inversion list.  This API
9940      * has an ambiguity, as it returns 0 under either the highest is actually
9941      * 0, or if the list is empty.  If this distinction matters to you, check
9942      * for emptiness before calling this function */
9943
9944     UV len = _invlist_len(invlist);
9945     UV *array;
9946
9947     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9948
9949     if (len == 0) {
9950         return 0;
9951     }
9952
9953     array = invlist_array(invlist);
9954
9955     /* The last element in the array in the inversion list always starts a
9956      * range that goes to infinity.  That range may be for code points that are
9957      * matched in the inversion list, or it may be for ones that aren't
9958      * matched.  In the latter case, the highest code point in the set is one
9959      * less than the beginning of this range; otherwise it is the final element
9960      * of this range: infinity */
9961     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9962            ? UV_MAX
9963            : array[len - 1] - 1;
9964 }
9965
9966 STATIC SV *
9967 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
9968 {
9969     /* Get the contents of an inversion list into a string SV so that they can
9970      * be printed out.  If 'traditional_style' is TRUE, it uses the format
9971      * traditionally done for debug tracing; otherwise it uses a format
9972      * suitable for just copying to the output, with blanks between ranges and
9973      * a dash between range components */
9974
9975     UV start, end;
9976     SV* output;
9977     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
9978     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
9979
9980     if (traditional_style) {
9981         output = newSVpvs("\n");
9982     }
9983     else {
9984         output = newSVpvs("");
9985     }
9986
9987     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
9988
9989     assert(! invlist_is_iterating(invlist));
9990
9991     invlist_iterinit(invlist);
9992     while (invlist_iternext(invlist, &start, &end)) {
9993         if (end == UV_MAX) {
9994             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFINITY%c",
9995                                           start, intra_range_delimiter,
9996                                                  inter_range_delimiter);
9997         }
9998         else if (end != start) {
9999             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10000                                           start,
10001                                                    intra_range_delimiter,
10002                                                   end, inter_range_delimiter);
10003         }
10004         else {
10005             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10006                                           start, inter_range_delimiter);
10007         }
10008     }
10009
10010     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10011         SvCUR_set(output, SvCUR(output) - 1);
10012     }
10013
10014     return output;
10015 }
10016
10017 #ifndef PERL_IN_XSUB_RE
10018 void
10019 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10020                          const char * const indent, SV* const invlist)
10021 {
10022     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10023      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10024      * the string 'indent'.  The output looks like this:
10025          [0] 0x000A .. 0x000D
10026          [2] 0x0085
10027          [4] 0x2028 .. 0x2029
10028          [6] 0x3104 .. INFINITY
10029      * This means that the first range of code points matched by the list are
10030      * 0xA through 0xD; the second range contains only the single code point
10031      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10032      * are used to define each range (except if the final range extends to
10033      * infinity, only a single element is needed).  The array index of the
10034      * first element for the corresponding range is given in brackets. */
10035
10036     UV start, end;
10037     STRLEN count = 0;
10038
10039     PERL_ARGS_ASSERT__INVLIST_DUMP;
10040
10041     if (invlist_is_iterating(invlist)) {
10042         Perl_dump_indent(aTHX_ level, file,
10043              "%sCan't dump inversion list because is in middle of iterating\n",
10044              indent);
10045         return;
10046     }
10047
10048     invlist_iterinit(invlist);
10049     while (invlist_iternext(invlist, &start, &end)) {
10050         if (end == UV_MAX) {
10051             Perl_dump_indent(aTHX_ level, file,
10052                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFINITY\n",
10053                                    indent, (UV)count, start);
10054         }
10055         else if (end != start) {
10056             Perl_dump_indent(aTHX_ level, file,
10057                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10058                                 indent, (UV)count, start,         end);
10059         }
10060         else {
10061             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10062                                             indent, (UV)count, start);
10063         }
10064         count += 2;
10065     }
10066 }
10067
10068 void
10069 Perl__load_PL_utf8_foldclosures (pTHX)
10070 {
10071     assert(! PL_utf8_foldclosures);
10072
10073     /* If the folds haven't been read in, call a fold function
10074      * to force that */
10075     if (! PL_utf8_tofold) {
10076         U8 dummy[UTF8_MAXBYTES_CASE+1];
10077         const U8 hyphen[] = HYPHEN_UTF8;
10078
10079         /* This string is just a short named one above \xff */
10080         toFOLD_utf8_safe(hyphen, hyphen + sizeof(hyphen) - 1, dummy, NULL);
10081         assert(PL_utf8_tofold); /* Verify that worked */
10082     }
10083     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10084 }
10085 #endif
10086
10087 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10088 bool
10089 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10090 {
10091     /* Return a boolean as to if the two passed in inversion lists are
10092      * identical.  The final argument, if TRUE, says to take the complement of
10093      * the second inversion list before doing the comparison */
10094
10095     const UV* array_a = invlist_array(a);
10096     const UV* array_b = invlist_array(b);
10097     UV len_a = _invlist_len(a);
10098     UV len_b = _invlist_len(b);
10099
10100     PERL_ARGS_ASSERT__INVLISTEQ;
10101
10102     /* If are to compare 'a' with the complement of b, set it
10103      * up so are looking at b's complement. */
10104     if (complement_b) {
10105
10106         /* The complement of nothing is everything, so <a> would have to have
10107          * just one element, starting at zero (ending at infinity) */
10108         if (len_b == 0) {
10109             return (len_a == 1 && array_a[0] == 0);
10110         }
10111         else if (array_b[0] == 0) {
10112
10113             /* Otherwise, to complement, we invert.  Here, the first element is
10114              * 0, just remove it.  To do this, we just pretend the array starts
10115              * one later */
10116
10117             array_b++;
10118             len_b--;
10119         }
10120         else {
10121
10122             /* But if the first element is not zero, we pretend the list starts
10123              * at the 0 that is always stored immediately before the array. */
10124             array_b--;
10125             len_b++;
10126         }
10127     }
10128
10129     return    len_a == len_b
10130            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10131
10132 }
10133 #endif
10134
10135 /*
10136  * As best we can, determine the characters that can match the start of
10137  * the given EXACTF-ish node.
10138  *
10139  * Returns the invlist as a new SV*; it is the caller's responsibility to
10140  * call SvREFCNT_dec() when done with it.
10141  */
10142 STATIC SV*
10143 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10144 {
10145     const U8 * s = (U8*)STRING(node);
10146     SSize_t bytelen = STR_LEN(node);
10147     UV uc;
10148     /* Start out big enough for 2 separate code points */
10149     SV* invlist = _new_invlist(4);
10150
10151     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10152
10153     if (! UTF) {
10154         uc = *s;
10155
10156         /* We punt and assume can match anything if the node begins
10157          * with a multi-character fold.  Things are complicated.  For
10158          * example, /ffi/i could match any of:
10159          *  "\N{LATIN SMALL LIGATURE FFI}"
10160          *  "\N{LATIN SMALL LIGATURE FF}I"
10161          *  "F\N{LATIN SMALL LIGATURE FI}"
10162          *  plus several other things; and making sure we have all the
10163          *  possibilities is hard. */
10164         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10165             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10166         }
10167         else {
10168             /* Any Latin1 range character can potentially match any
10169              * other depending on the locale */
10170             if (OP(node) == EXACTFL) {
10171                 _invlist_union(invlist, PL_Latin1, &invlist);
10172             }
10173             else {
10174                 /* But otherwise, it matches at least itself.  We can
10175                  * quickly tell if it has a distinct fold, and if so,
10176                  * it matches that as well */
10177                 invlist = add_cp_to_invlist(invlist, uc);
10178                 if (IS_IN_SOME_FOLD_L1(uc))
10179                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10180             }
10181
10182             /* Some characters match above-Latin1 ones under /i.  This
10183              * is true of EXACTFL ones when the locale is UTF-8 */
10184             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10185                 && (! isASCII(uc) || (OP(node) != EXACTFA
10186                                     && OP(node) != EXACTFA_NO_TRIE)))
10187             {
10188                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10189             }
10190         }
10191     }
10192     else {  /* Pattern is UTF-8 */
10193         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10194         STRLEN foldlen = UTF8SKIP(s);
10195         const U8* e = s + bytelen;
10196         SV** listp;
10197
10198         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10199
10200         /* The only code points that aren't folded in a UTF EXACTFish
10201          * node are are the problematic ones in EXACTFL nodes */
10202         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10203             /* We need to check for the possibility that this EXACTFL
10204              * node begins with a multi-char fold.  Therefore we fold
10205              * the first few characters of it so that we can make that
10206              * check */
10207             U8 *d = folded;
10208             int i;
10209
10210             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10211                 if (isASCII(*s)) {
10212                     *(d++) = (U8) toFOLD(*s);
10213                     s++;
10214                 }
10215                 else {
10216                     STRLEN len;
10217                     toFOLD_utf8_safe(s, e, d, &len);
10218                     d += len;
10219                     s += UTF8SKIP(s);
10220                 }
10221             }
10222
10223             /* And set up so the code below that looks in this folded
10224              * buffer instead of the node's string */
10225             e = d;
10226             foldlen = UTF8SKIP(folded);
10227             s = folded;
10228         }
10229
10230         /* When we reach here 's' points to the fold of the first
10231          * character(s) of the node; and 'e' points to far enough along
10232          * the folded string to be just past any possible multi-char
10233          * fold. 'foldlen' is the length in bytes of the first
10234          * character in 's'
10235          *
10236          * Unlike the non-UTF-8 case, the macro for determining if a
10237          * string is a multi-char fold requires all the characters to
10238          * already be folded.  This is because of all the complications
10239          * if not.  Note that they are folded anyway, except in EXACTFL
10240          * nodes.  Like the non-UTF case above, we punt if the node
10241          * begins with a multi-char fold  */
10242
10243         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10244             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10245         }
10246         else {  /* Single char fold */
10247
10248             /* It matches all the things that fold to it, which are
10249              * found in PL_utf8_foldclosures (including itself) */
10250             invlist = add_cp_to_invlist(invlist, uc);
10251             if (! PL_utf8_foldclosures)
10252                 _load_PL_utf8_foldclosures();
10253             if ((listp = hv_fetch(PL_utf8_foldclosures,
10254                                 (char *) s, foldlen, FALSE)))
10255             {
10256                 AV* list = (AV*) *listp;
10257                 IV k;
10258                 for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
10259                     SV** c_p = av_fetch(list, k, FALSE);
10260                     UV c;
10261                     assert(c_p);
10262
10263                     c = SvUV(*c_p);
10264
10265                     /* /aa doesn't allow folds between ASCII and non- */
10266                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
10267                         && isASCII(c) != isASCII(uc))
10268                     {
10269                         continue;
10270                     }
10271
10272                     invlist = add_cp_to_invlist(invlist, c);
10273                 }
10274             }
10275         }
10276     }
10277
10278     return invlist;
10279 }
10280
10281 #undef HEADER_LENGTH
10282 #undef TO_INTERNAL_SIZE
10283 #undef FROM_INTERNAL_SIZE
10284 #undef INVLIST_VERSION_ID
10285
10286 /* End of inversion list object */
10287
10288 STATIC void
10289 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10290 {
10291     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10292      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10293      * should point to the first flag; it is updated on output to point to the
10294      * final ')' or ':'.  There needs to be at least one flag, or this will
10295      * abort */
10296
10297     /* for (?g), (?gc), and (?o) warnings; warning
10298        about (?c) will warn about (?g) -- japhy    */
10299
10300 #define WASTED_O  0x01
10301 #define WASTED_G  0x02
10302 #define WASTED_C  0x04
10303 #define WASTED_GC (WASTED_G|WASTED_C)
10304     I32 wastedflags = 0x00;
10305     U32 posflags = 0, negflags = 0;
10306     U32 *flagsp = &posflags;
10307     char has_charset_modifier = '\0';
10308     regex_charset cs;
10309     bool has_use_defaults = FALSE;
10310     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10311     int x_mod_count = 0;
10312
10313     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10314
10315     /* '^' as an initial flag sets certain defaults */
10316     if (UCHARAT(RExC_parse) == '^') {
10317         RExC_parse++;
10318         has_use_defaults = TRUE;
10319         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10320         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10321                                         ? REGEX_UNICODE_CHARSET
10322                                         : REGEX_DEPENDS_CHARSET);
10323     }
10324
10325     cs = get_regex_charset(RExC_flags);
10326     if (cs == REGEX_DEPENDS_CHARSET
10327         && (RExC_utf8 || RExC_uni_semantics))
10328     {
10329         cs = REGEX_UNICODE_CHARSET;
10330     }
10331
10332     while (RExC_parse < RExC_end) {
10333         /* && strchr("iogcmsx", *RExC_parse) */
10334         /* (?g), (?gc) and (?o) are useless here
10335            and must be globally applied -- japhy */
10336         switch (*RExC_parse) {
10337
10338             /* Code for the imsxn flags */
10339             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10340
10341             case LOCALE_PAT_MOD:
10342                 if (has_charset_modifier) {
10343                     goto excess_modifier;
10344                 }
10345                 else if (flagsp == &negflags) {
10346                     goto neg_modifier;
10347                 }
10348                 cs = REGEX_LOCALE_CHARSET;
10349                 has_charset_modifier = LOCALE_PAT_MOD;
10350                 break;
10351             case UNICODE_PAT_MOD:
10352                 if (has_charset_modifier) {
10353                     goto excess_modifier;
10354                 }
10355                 else if (flagsp == &negflags) {
10356                     goto neg_modifier;
10357                 }
10358                 cs = REGEX_UNICODE_CHARSET;
10359                 has_charset_modifier = UNICODE_PAT_MOD;
10360                 break;
10361             case ASCII_RESTRICT_PAT_MOD:
10362                 if (flagsp == &negflags) {
10363                     goto neg_modifier;
10364                 }
10365                 if (has_charset_modifier) {
10366                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10367                         goto excess_modifier;
10368                     }
10369                     /* Doubled modifier implies more restricted */
10370                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10371                 }
10372                 else {
10373                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10374                 }
10375                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10376                 break;
10377             case DEPENDS_PAT_MOD:
10378                 if (has_use_defaults) {
10379                     goto fail_modifiers;
10380                 }
10381                 else if (flagsp == &negflags) {
10382                     goto neg_modifier;
10383                 }
10384                 else if (has_charset_modifier) {
10385                     goto excess_modifier;
10386                 }
10387
10388                 /* The dual charset means unicode semantics if the
10389                  * pattern (or target, not known until runtime) are
10390                  * utf8, or something in the pattern indicates unicode
10391                  * semantics */
10392                 cs = (RExC_utf8 || RExC_uni_semantics)
10393                      ? REGEX_UNICODE_CHARSET
10394                      : REGEX_DEPENDS_CHARSET;
10395                 has_charset_modifier = DEPENDS_PAT_MOD;
10396                 break;
10397               excess_modifier:
10398                 RExC_parse++;
10399                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10400                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10401                 }
10402                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10403                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10404                                         *(RExC_parse - 1));
10405                 }
10406                 else {
10407                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10408                 }
10409                 NOT_REACHED; /*NOTREACHED*/
10410               neg_modifier:
10411                 RExC_parse++;
10412                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10413                                     *(RExC_parse - 1));
10414                 NOT_REACHED; /*NOTREACHED*/
10415             case ONCE_PAT_MOD: /* 'o' */
10416             case GLOBAL_PAT_MOD: /* 'g' */
10417                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10418                     const I32 wflagbit = *RExC_parse == 'o'
10419                                          ? WASTED_O
10420                                          : WASTED_G;
10421                     if (! (wastedflags & wflagbit) ) {
10422                         wastedflags |= wflagbit;
10423                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10424                         vWARN5(
10425                             RExC_parse + 1,
10426                             "Useless (%s%c) - %suse /%c modifier",
10427                             flagsp == &negflags ? "?-" : "?",
10428                             *RExC_parse,
10429                             flagsp == &negflags ? "don't " : "",
10430                             *RExC_parse
10431                         );
10432                     }
10433                 }
10434                 break;
10435
10436             case CONTINUE_PAT_MOD: /* 'c' */
10437                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10438                     if (! (wastedflags & WASTED_C) ) {
10439                         wastedflags |= WASTED_GC;
10440                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10441                         vWARN3(
10442                             RExC_parse + 1,
10443                             "Useless (%sc) - %suse /gc modifier",
10444                             flagsp == &negflags ? "?-" : "?",
10445                             flagsp == &negflags ? "don't " : ""
10446                         );
10447                     }
10448                 }
10449                 break;
10450             case KEEPCOPY_PAT_MOD: /* 'p' */
10451                 if (flagsp == &negflags) {
10452                     if (PASS2)
10453                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10454                 } else {
10455                     *flagsp |= RXf_PMf_KEEPCOPY;
10456                 }
10457                 break;
10458             case '-':
10459                 /* A flag is a default iff it is following a minus, so
10460                  * if there is a minus, it means will be trying to
10461                  * re-specify a default which is an error */
10462                 if (has_use_defaults || flagsp == &negflags) {
10463                     goto fail_modifiers;
10464                 }
10465                 flagsp = &negflags;
10466                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10467                 x_mod_count = 0;
10468                 break;
10469             case ':':
10470             case ')':
10471
10472                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
10473                     negflags |= RXf_PMf_EXTENDED_MORE;
10474                 }
10475                 RExC_flags |= posflags;
10476
10477                 if (negflags & RXf_PMf_EXTENDED) {
10478                     negflags |= RXf_PMf_EXTENDED_MORE;
10479                 }
10480                 RExC_flags &= ~negflags;
10481                 set_regex_charset(&RExC_flags, cs);
10482
10483                 return;
10484             default:
10485               fail_modifiers:
10486                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10487                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10488                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10489                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10490                 NOT_REACHED; /*NOTREACHED*/
10491         }
10492
10493         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10494     }
10495
10496     vFAIL("Sequence (?... not terminated");
10497 }
10498
10499 /*
10500  - reg - regular expression, i.e. main body or parenthesized thing
10501  *
10502  * Caller must absorb opening parenthesis.
10503  *
10504  * Combining parenthesis handling with the base level of regular expression
10505  * is a trifle forced, but the need to tie the tails of the branches to what
10506  * follows makes it hard to avoid.
10507  */
10508 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10509 #ifdef DEBUGGING
10510 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10511 #else
10512 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10513 #endif
10514
10515 PERL_STATIC_INLINE regnode *
10516 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10517                              I32 *flagp,
10518                              char * parse_start,
10519                              char ch
10520                       )
10521 {
10522     regnode *ret;
10523     char* name_start = RExC_parse;
10524     U32 num = 0;
10525     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10526                                             ? REG_RSN_RETURN_NULL
10527                                             : REG_RSN_RETURN_DATA);
10528     GET_RE_DEBUG_FLAGS_DECL;
10529
10530     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10531
10532     if (RExC_parse == name_start || *RExC_parse != ch) {
10533         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10534         vFAIL2("Sequence %.3s... not terminated",parse_start);
10535     }
10536
10537     if (!SIZE_ONLY) {
10538         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10539         RExC_rxi->data->data[num]=(void*)sv_dat;
10540         SvREFCNT_inc_simple_void(sv_dat);
10541     }
10542     RExC_sawback = 1;
10543     ret = reganode(pRExC_state,
10544                    ((! FOLD)
10545                      ? NREF
10546                      : (ASCII_FOLD_RESTRICTED)
10547                        ? NREFFA
10548                        : (AT_LEAST_UNI_SEMANTICS)
10549                          ? NREFFU
10550                          : (LOC)
10551                            ? NREFFL
10552                            : NREFF),
10553                     num);
10554     *flagp |= HASWIDTH;
10555
10556     Set_Node_Offset(ret, parse_start+1);
10557     Set_Node_Cur_Length(ret, parse_start);
10558
10559     nextchar(pRExC_state);
10560     return ret;
10561 }
10562
10563 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10564    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10565    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10566    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10567    NULL, which cannot happen.  */
10568 STATIC regnode *
10569 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10570     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10571      * 2 is like 1, but indicates that nextchar() has been called to advance
10572      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10573      * this flag alerts us to the need to check for that */
10574 {
10575     regnode *ret;               /* Will be the head of the group. */
10576     regnode *br;
10577     regnode *lastbr;
10578     regnode *ender = NULL;
10579     I32 parno = 0;
10580     I32 flags;
10581     U32 oregflags = RExC_flags;
10582     bool have_branch = 0;
10583     bool is_open = 0;
10584     I32 freeze_paren = 0;
10585     I32 after_freeze = 0;
10586     I32 num; /* numeric backreferences */
10587
10588     char * parse_start = RExC_parse; /* MJD */
10589     char * const oregcomp_parse = RExC_parse;
10590
10591     GET_RE_DEBUG_FLAGS_DECL;
10592
10593     PERL_ARGS_ASSERT_REG;
10594     DEBUG_PARSE("reg ");
10595
10596     *flagp = 0;                         /* Tentatively. */
10597
10598     /* Having this true makes it feasible to have a lot fewer tests for the
10599      * parse pointer being in scope.  For example, we can write
10600      *      while(isFOO(*RExC_parse)) RExC_parse++;
10601      * instead of
10602      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10603      */
10604     assert(*RExC_end == '\0');
10605
10606     /* Make an OPEN node, if parenthesized. */
10607     if (paren) {
10608
10609         /* Under /x, space and comments can be gobbled up between the '(' and
10610          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10611          * intervening space, as the sequence is a token, and a token should be
10612          * indivisible */
10613         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
10614
10615         if (RExC_parse >= RExC_end) {
10616             vFAIL("Unmatched (");
10617         }
10618
10619         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
10620             char *start_verb = RExC_parse + 1;
10621             STRLEN verb_len;
10622             char *start_arg = NULL;
10623             unsigned char op = 0;
10624             int arg_required = 0;
10625             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10626
10627             if (has_intervening_patws) {
10628                 RExC_parse++;   /* past the '*' */
10629                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10630             }
10631             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10632                 if ( *RExC_parse == ':' ) {
10633                     start_arg = RExC_parse + 1;
10634                     break;
10635                 }
10636                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10637             }
10638             verb_len = RExC_parse - start_verb;
10639             if ( start_arg ) {
10640                 if (RExC_parse >= RExC_end) {
10641                     goto unterminated_verb_pattern;
10642                 }
10643                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10644                 while ( RExC_parse < RExC_end && *RExC_parse != ')' )
10645                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10646                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10647                   unterminated_verb_pattern:
10648                     vFAIL("Unterminated verb pattern argument");
10649                 if ( RExC_parse == start_arg )
10650                     start_arg = NULL;
10651             } else {
10652                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10653                     vFAIL("Unterminated verb pattern");
10654             }
10655
10656             /* Here, we know that RExC_parse < RExC_end */
10657
10658             switch ( *start_verb ) {
10659             case 'A':  /* (*ACCEPT) */
10660                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10661                     op = ACCEPT;
10662                     internal_argval = RExC_nestroot;
10663                 }
10664                 break;
10665             case 'C':  /* (*COMMIT) */
10666                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10667                     op = COMMIT;
10668                 break;
10669             case 'F':  /* (*FAIL) */
10670                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10671                     op = OPFAIL;
10672                 }
10673                 break;
10674             case ':':  /* (*:NAME) */
10675             case 'M':  /* (*MARK:NAME) */
10676                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10677                     op = MARKPOINT;
10678                     arg_required = 1;
10679                 }
10680                 break;
10681             case 'P':  /* (*PRUNE) */
10682                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10683                     op = PRUNE;
10684                 break;
10685             case 'S':   /* (*SKIP) */
10686                 if ( memEQs(start_verb,verb_len,"SKIP") )
10687                     op = SKIP;
10688                 break;
10689             case 'T':  /* (*THEN) */
10690                 /* [19:06] <TimToady> :: is then */
10691                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10692                     op = CUTGROUP;
10693                     RExC_seen |= REG_CUTGROUP_SEEN;
10694                 }
10695                 break;
10696             }
10697             if ( ! op ) {
10698                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10699                 vFAIL2utf8f(
10700                     "Unknown verb pattern '%" UTF8f "'",
10701                     UTF8fARG(UTF, verb_len, start_verb));
10702             }
10703             if ( arg_required && !start_arg ) {
10704                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
10705                     verb_len, start_verb);
10706             }
10707             if (internal_argval == -1) {
10708                 ret = reganode(pRExC_state, op, 0);
10709             } else {
10710                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
10711             }
10712             RExC_seen |= REG_VERBARG_SEEN;
10713             if ( ! SIZE_ONLY ) {
10714                 if (start_arg) {
10715                     SV *sv = newSVpvn( start_arg,
10716                                        RExC_parse - start_arg);
10717                     ARG(ret) = add_data( pRExC_state,
10718                                          STR_WITH_LEN("S"));
10719                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
10720                     ret->flags = 1;
10721                 } else {
10722                     ret->flags = 0;
10723                 }
10724                 if ( internal_argval != -1 )
10725                     ARG2L_SET(ret, internal_argval);
10726             }
10727             nextchar(pRExC_state);
10728             return ret;
10729         }
10730         else if (*RExC_parse == '?') { /* (?...) */
10731             bool is_logical = 0;
10732             const char * const seqstart = RExC_parse;
10733             const char * endptr;
10734             if (has_intervening_patws) {
10735                 RExC_parse++;
10736                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
10737             }
10738
10739             RExC_parse++;           /* past the '?' */
10740             paren = *RExC_parse;    /* might be a trailing NUL, if not
10741                                        well-formed */
10742             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10743             if (RExC_parse > RExC_end) {
10744                 paren = '\0';
10745             }
10746             ret = NULL;                 /* For look-ahead/behind. */
10747             switch (paren) {
10748
10749             case 'P':   /* (?P...) variants for those used to PCRE/Python */
10750                 paren = *RExC_parse;
10751                 if ( paren == '<') {    /* (?P<...>) named capture */
10752                     RExC_parse++;
10753                     if (RExC_parse >= RExC_end) {
10754                         vFAIL("Sequence (?P<... not terminated");
10755                     }
10756                     goto named_capture;
10757                 }
10758                 else if (paren == '>') {   /* (?P>name) named recursion */
10759                     RExC_parse++;
10760                     if (RExC_parse >= RExC_end) {
10761                         vFAIL("Sequence (?P>... not terminated");
10762                     }
10763                     goto named_recursion;
10764                 }
10765                 else if (paren == '=') {   /* (?P=...)  named backref */
10766                     RExC_parse++;
10767                     return handle_named_backref(pRExC_state, flagp,
10768                                                 parse_start, ')');
10769                 }
10770                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10771                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10772                 vFAIL3("Sequence (%.*s...) not recognized",
10773                                 RExC_parse-seqstart, seqstart);
10774                 NOT_REACHED; /*NOTREACHED*/
10775             case '<':           /* (?<...) */
10776                 if (*RExC_parse == '!')
10777                     paren = ',';
10778                 else if (*RExC_parse != '=')
10779               named_capture:
10780                 {               /* (?<...>) */
10781                     char *name_start;
10782                     SV *svname;
10783                     paren= '>';
10784                 /* FALLTHROUGH */
10785             case '\'':          /* (?'...') */
10786                     name_start = RExC_parse;
10787                     svname = reg_scan_name(pRExC_state,
10788                         SIZE_ONLY    /* reverse test from the others */
10789                         ? REG_RSN_RETURN_NAME
10790                         : REG_RSN_RETURN_NULL);
10791                     if (   RExC_parse == name_start
10792                         || RExC_parse >= RExC_end
10793                         || *RExC_parse != paren)
10794                     {
10795                         vFAIL2("Sequence (?%c... not terminated",
10796                             paren=='>' ? '<' : paren);
10797                     }
10798                     if (SIZE_ONLY) {
10799                         HE *he_str;
10800                         SV *sv_dat = NULL;
10801                         if (!svname) /* shouldn't happen */
10802                             Perl_croak(aTHX_
10803                                 "panic: reg_scan_name returned NULL");
10804                         if (!RExC_paren_names) {
10805                             RExC_paren_names= newHV();
10806                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10807 #ifdef DEBUGGING
10808                             RExC_paren_name_list= newAV();
10809                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10810 #endif
10811                         }
10812                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10813                         if ( he_str )
10814                             sv_dat = HeVAL(he_str);
10815                         if ( ! sv_dat ) {
10816                             /* croak baby croak */
10817                             Perl_croak(aTHX_
10818                                 "panic: paren_name hash element allocation failed");
10819                         } else if ( SvPOK(sv_dat) ) {
10820                             /* (?|...) can mean we have dupes so scan to check
10821                                its already been stored. Maybe a flag indicating
10822                                we are inside such a construct would be useful,
10823                                but the arrays are likely to be quite small, so
10824                                for now we punt -- dmq */
10825                             IV count = SvIV(sv_dat);
10826                             I32 *pv = (I32*)SvPVX(sv_dat);
10827                             IV i;
10828                             for ( i = 0 ; i < count ; i++ ) {
10829                                 if ( pv[i] == RExC_npar ) {
10830                                     count = 0;
10831                                     break;
10832                                 }
10833                             }
10834                             if ( count ) {
10835                                 pv = (I32*)SvGROW(sv_dat,
10836                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10837                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10838                                 pv[count] = RExC_npar;
10839                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10840                             }
10841                         } else {
10842                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10843                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10844                                                                 sizeof(I32));
10845                             SvIOK_on(sv_dat);
10846                             SvIV_set(sv_dat, 1);
10847                         }
10848 #ifdef DEBUGGING
10849                         /* Yes this does cause a memory leak in debugging Perls
10850                          * */
10851                         if (!av_store(RExC_paren_name_list,
10852                                       RExC_npar, SvREFCNT_inc(svname)))
10853                             SvREFCNT_dec_NN(svname);
10854 #endif
10855
10856                         /*sv_dump(sv_dat);*/
10857                     }
10858                     nextchar(pRExC_state);
10859                     paren = 1;
10860                     goto capturing_parens;
10861                 }
10862                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10863                 RExC_in_lookbehind++;
10864                 RExC_parse++;
10865                 if (RExC_parse >= RExC_end) {
10866                     vFAIL("Sequence (?... not terminated");
10867                 }
10868
10869                 /* FALLTHROUGH */
10870             case '=':           /* (?=...) */
10871                 RExC_seen_zerolen++;
10872                 break;
10873             case '!':           /* (?!...) */
10874                 RExC_seen_zerolen++;
10875                 /* check if we're really just a "FAIL" assertion */
10876                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
10877                                         FALSE /* Don't force to /x */ );
10878                 if (*RExC_parse == ')') {
10879                     ret=reganode(pRExC_state, OPFAIL, 0);
10880                     nextchar(pRExC_state);
10881                     return ret;
10882                 }
10883                 break;
10884             case '|':           /* (?|...) */
10885                 /* branch reset, behave like a (?:...) except that
10886                    buffers in alternations share the same numbers */
10887                 paren = ':';
10888                 after_freeze = freeze_paren = RExC_npar;
10889                 break;
10890             case ':':           /* (?:...) */
10891             case '>':           /* (?>...) */
10892                 break;
10893             case '$':           /* (?$...) */
10894             case '@':           /* (?@...) */
10895                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10896                 break;
10897             case '0' :           /* (?0) */
10898             case 'R' :           /* (?R) */
10899                 if (RExC_parse == RExC_end || *RExC_parse != ')')
10900                     FAIL("Sequence (?R) not terminated");
10901                 num = 0;
10902                 RExC_seen |= REG_RECURSE_SEEN;
10903                 *flagp |= POSTPONED;
10904                 goto gen_recurse_regop;
10905                 /*notreached*/
10906             /* named and numeric backreferences */
10907             case '&':            /* (?&NAME) */
10908                 parse_start = RExC_parse - 1;
10909               named_recursion:
10910                 {
10911                     SV *sv_dat = reg_scan_name(pRExC_state,
10912                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10913                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10914                 }
10915                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
10916                     vFAIL("Sequence (?&... not terminated");
10917                 goto gen_recurse_regop;
10918                 /* NOTREACHED */
10919             case '+':
10920                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10921                     RExC_parse++;
10922                     vFAIL("Illegal pattern");
10923                 }
10924                 goto parse_recursion;
10925                 /* NOTREACHED*/
10926             case '-': /* (?-1) */
10927                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10928                     RExC_parse--; /* rewind to let it be handled later */
10929                     goto parse_flags;
10930                 }
10931                 /* FALLTHROUGH */
10932             case '1': case '2': case '3': case '4': /* (?1) */
10933             case '5': case '6': case '7': case '8': case '9':
10934                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
10935               parse_recursion:
10936                 {
10937                     bool is_neg = FALSE;
10938                     UV unum;
10939                     parse_start = RExC_parse - 1; /* MJD */
10940                     if (*RExC_parse == '-') {
10941                         RExC_parse++;
10942                         is_neg = TRUE;
10943                     }
10944                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10945                         && unum <= I32_MAX
10946                     ) {
10947                         num = (I32)unum;
10948                         RExC_parse = (char*)endptr;
10949                     } else
10950                         num = I32_MAX;
10951                     if (is_neg) {
10952                         /* Some limit for num? */
10953                         num = -num;
10954                     }
10955                 }
10956                 if (*RExC_parse!=')')
10957                     vFAIL("Expecting close bracket");
10958
10959               gen_recurse_regop:
10960                 if ( paren == '-' ) {
10961                     /*
10962                     Diagram of capture buffer numbering.
10963                     Top line is the normal capture buffer numbers
10964                     Bottom line is the negative indexing as from
10965                     the X (the (?-2))
10966
10967                     +   1 2    3 4 5 X          6 7
10968                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
10969                     -   5 4    3 2 1 X          x x
10970
10971                     */
10972                     num = RExC_npar + num;
10973                     if (num < 1)  {
10974                         RExC_parse++;
10975                         vFAIL("Reference to nonexistent group");
10976                     }
10977                 } else if ( paren == '+' ) {
10978                     num = RExC_npar + num - 1;
10979                 }
10980                 /* We keep track how many GOSUB items we have produced.
10981                    To start off the ARG2L() of the GOSUB holds its "id",
10982                    which is used later in conjunction with RExC_recurse
10983                    to calculate the offset we need to jump for the GOSUB,
10984                    which it will store in the final representation.
10985                    We have to defer the actual calculation until much later
10986                    as the regop may move.
10987                  */
10988
10989                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
10990                 if (!SIZE_ONLY) {
10991                     if (num > (I32)RExC_rx->nparens) {
10992                         RExC_parse++;
10993                         vFAIL("Reference to nonexistent group");
10994                     }
10995                     RExC_recurse_count++;
10996                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
10997                         "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
10998                               22, "|    |", (int)(depth * 2 + 1), "",
10999                               (UV)ARG(ret), (IV)ARG2L(ret)));
11000                 }
11001                 RExC_seen |= REG_RECURSE_SEEN;
11002
11003                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
11004                 Set_Node_Offset(ret, parse_start); /* MJD */
11005
11006                 *flagp |= POSTPONED;
11007                 assert(*RExC_parse == ')');
11008                 nextchar(pRExC_state);
11009                 return ret;
11010
11011             /* NOTREACHED */
11012
11013             case '?':           /* (??...) */
11014                 is_logical = 1;
11015                 if (*RExC_parse != '{') {
11016                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
11017                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11018                     vFAIL2utf8f(
11019                         "Sequence (%" UTF8f "...) not recognized",
11020                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11021                     NOT_REACHED; /*NOTREACHED*/
11022                 }
11023                 *flagp |= POSTPONED;
11024                 paren = '{';
11025                 RExC_parse++;
11026                 /* FALLTHROUGH */
11027             case '{':           /* (?{...}) */
11028             {
11029                 U32 n = 0;
11030                 struct reg_code_block *cb;
11031
11032                 RExC_seen_zerolen++;
11033
11034                 if (   !pRExC_state->code_blocks
11035                     || pRExC_state->code_index
11036                                         >= pRExC_state->code_blocks->count
11037                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11038                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11039                             - RExC_start)
11040                 ) {
11041                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11042                         FAIL("panic: Sequence (?{...}): no code block found\n");
11043                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11044                 }
11045                 /* this is a pre-compiled code block (?{...}) */
11046                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11047                 RExC_parse = RExC_start + cb->end;
11048                 if (!SIZE_ONLY) {
11049                     OP *o = cb->block;
11050                     if (cb->src_regex) {
11051                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11052                         RExC_rxi->data->data[n] =
11053                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
11054                         RExC_rxi->data->data[n+1] = (void*)o;
11055                     }
11056                     else {
11057                         n = add_data(pRExC_state,
11058                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11059                         RExC_rxi->data->data[n] = (void*)o;
11060                     }
11061                 }
11062                 pRExC_state->code_index++;
11063                 nextchar(pRExC_state);
11064
11065                 if (is_logical) {
11066                     regnode *eval;
11067                     ret = reg_node(pRExC_state, LOGICAL);
11068
11069                     eval = reg2Lanode(pRExC_state, EVAL,
11070                                        n,
11071
11072                                        /* for later propagation into (??{})
11073                                         * return value */
11074                                        RExC_flags & RXf_PMf_COMPILETIME
11075                                       );
11076                     if (!SIZE_ONLY) {
11077                         ret->flags = 2;
11078                     }
11079                     REGTAIL(pRExC_state, ret, eval);
11080                     /* deal with the length of this later - MJD */
11081                     return ret;
11082                 }
11083                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11084                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
11085                 Set_Node_Offset(ret, parse_start);
11086                 return ret;
11087             }
11088             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11089             {
11090                 int is_define= 0;
11091                 const int DEFINE_len = sizeof("DEFINE") - 1;
11092                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
11093                     if (   RExC_parse < RExC_end - 1
11094                         && (   RExC_parse[1] == '='
11095                             || RExC_parse[1] == '!'
11096                             || RExC_parse[1] == '<'
11097                             || RExC_parse[1] == '{')
11098                     ) { /* Lookahead or eval. */
11099                         I32 flag;
11100                         regnode *tail;
11101
11102                         ret = reg_node(pRExC_state, LOGICAL);
11103                         if (!SIZE_ONLY)
11104                             ret->flags = 1;
11105
11106                         tail = reg(pRExC_state, 1, &flag, depth+1);
11107                         if (flag & (RESTART_PASS1|NEED_UTF8)) {
11108                             *flagp = flag & (RESTART_PASS1|NEED_UTF8);
11109                             return NULL;
11110                         }
11111                         REGTAIL(pRExC_state, ret, tail);
11112                         goto insert_if;
11113                     }
11114                     /* Fall through to ‘Unknown switch condition’ at the
11115                        end of the if/else chain. */
11116                 }
11117                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11118                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11119                 {
11120                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11121                     char *name_start= RExC_parse++;
11122                     U32 num = 0;
11123                     SV *sv_dat=reg_scan_name(pRExC_state,
11124                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11125                     if (   RExC_parse == name_start
11126                         || RExC_parse >= RExC_end
11127                         || *RExC_parse != ch)
11128                     {
11129                         vFAIL2("Sequence (?(%c... not terminated",
11130                             (ch == '>' ? '<' : ch));
11131                     }
11132                     RExC_parse++;
11133                     if (!SIZE_ONLY) {
11134                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11135                         RExC_rxi->data->data[num]=(void*)sv_dat;
11136                         SvREFCNT_inc_simple_void(sv_dat);
11137                     }
11138                     ret = reganode(pRExC_state,NGROUPP,num);
11139                     goto insert_if_check_paren;
11140                 }
11141                 else if (RExC_end - RExC_parse >= DEFINE_len
11142                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
11143                 {
11144                     ret = reganode(pRExC_state,DEFINEP,0);
11145                     RExC_parse += DEFINE_len;
11146                     is_define = 1;
11147                     goto insert_if_check_paren;
11148                 }
11149                 else if (RExC_parse[0] == 'R') {
11150                     RExC_parse++;
11151                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11152                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11153                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11154                      */
11155                     parno = 0;
11156                     if (RExC_parse[0] == '0') {
11157                         parno = 1;
11158                         RExC_parse++;
11159                     }
11160                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11161                         UV uv;
11162                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11163                             && uv <= I32_MAX
11164                         ) {
11165                             parno = (I32)uv + 1;
11166                             RExC_parse = (char*)endptr;
11167                         }
11168                         /* else "Switch condition not recognized" below */
11169                     } else if (RExC_parse[0] == '&') {
11170                         SV *sv_dat;
11171                         RExC_parse++;
11172                         sv_dat = reg_scan_name(pRExC_state,
11173                             SIZE_ONLY
11174                             ? REG_RSN_RETURN_NULL
11175                             : REG_RSN_RETURN_DATA);
11176
11177                         /* we should only have a false sv_dat when
11178                          * SIZE_ONLY is true, and we always have false
11179                          * sv_dat when SIZE_ONLY is true.
11180                          * reg_scan_name() will VFAIL() if the name is
11181                          * unknown when SIZE_ONLY is false, and otherwise
11182                          * will return something, and when SIZE_ONLY is
11183                          * true, reg_scan_name() just parses the string,
11184                          * and doesnt return anything. (in theory) */
11185                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
11186
11187                         if (sv_dat)
11188                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11189                     }
11190                     ret = reganode(pRExC_state,INSUBP,parno);
11191                     goto insert_if_check_paren;
11192                 }
11193                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11194                     /* (?(1)...) */
11195                     char c;
11196                     UV uv;
11197                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11198                         && uv <= I32_MAX
11199                     ) {
11200                         parno = (I32)uv;
11201                         RExC_parse = (char*)endptr;
11202                     }
11203                     else {
11204                         vFAIL("panic: grok_atoUV returned FALSE");
11205                     }
11206                     ret = reganode(pRExC_state, GROUPP, parno);
11207
11208                  insert_if_check_paren:
11209                     if (UCHARAT(RExC_parse) != ')') {
11210                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11211                         vFAIL("Switch condition not recognized");
11212                     }
11213                     nextchar(pRExC_state);
11214                   insert_if:
11215                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11216                     br = regbranch(pRExC_state, &flags, 1,depth+1);
11217                     if (br == NULL) {
11218                         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11219                             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11220                             return NULL;
11221                         }
11222                         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11223                               (UV) flags);
11224                     } else
11225                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11226                                                           LONGJMP, 0));
11227                     c = UCHARAT(RExC_parse);
11228                     nextchar(pRExC_state);
11229                     if (flags&HASWIDTH)
11230                         *flagp |= HASWIDTH;
11231                     if (c == '|') {
11232                         if (is_define)
11233                             vFAIL("(?(DEFINE)....) does not allow branches");
11234
11235                         /* Fake one for optimizer.  */
11236                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11237
11238                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
11239                             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11240                                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11241                                 return NULL;
11242                             }
11243                             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11244                                   (UV) flags);
11245                         }
11246                         REGTAIL(pRExC_state, ret, lastbr);
11247                         if (flags&HASWIDTH)
11248                             *flagp |= HASWIDTH;
11249                         c = UCHARAT(RExC_parse);
11250                         nextchar(pRExC_state);
11251                     }
11252                     else
11253                         lastbr = NULL;
11254                     if (c != ')') {
11255                         if (RExC_parse >= RExC_end)
11256                             vFAIL("Switch (?(condition)... not terminated");
11257                         else
11258                             vFAIL("Switch (?(condition)... contains too many branches");
11259                     }
11260                     ender = reg_node(pRExC_state, TAIL);
11261                     REGTAIL(pRExC_state, br, ender);
11262                     if (lastbr) {
11263                         REGTAIL(pRExC_state, lastbr, ender);
11264                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11265                     }
11266                     else
11267                         REGTAIL(pRExC_state, ret, ender);
11268                     RExC_size++; /* XXX WHY do we need this?!!
11269                                     For large programs it seems to be required
11270                                     but I can't figure out why. -- dmq*/
11271                     return ret;
11272                 }
11273                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11274                 vFAIL("Unknown switch condition (?(...))");
11275             }
11276             case '[':           /* (?[ ... ]) */
11277                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
11278                                          oregcomp_parse);
11279             case 0: /* A NUL */
11280                 RExC_parse--; /* for vFAIL to print correctly */
11281                 vFAIL("Sequence (? incomplete");
11282                 break;
11283             default: /* e.g., (?i) */
11284                 RExC_parse = (char *) seqstart + 1;
11285               parse_flags:
11286                 parse_lparen_question_flags(pRExC_state);
11287                 if (UCHARAT(RExC_parse) != ':') {
11288                     if (RExC_parse < RExC_end)
11289                         nextchar(pRExC_state);
11290                     *flagp = TRYAGAIN;
11291                     return NULL;
11292                 }
11293                 paren = ':';
11294                 nextchar(pRExC_state);
11295                 ret = NULL;
11296                 goto parse_rest;
11297             } /* end switch */
11298         }
11299         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11300           capturing_parens:
11301             parno = RExC_npar;
11302             RExC_npar++;
11303
11304             ret = reganode(pRExC_state, OPEN, parno);
11305             if (!SIZE_ONLY ){
11306                 if (!RExC_nestroot)
11307                     RExC_nestroot = parno;
11308                 if (RExC_open_parens && !RExC_open_parens[parno])
11309                 {
11310                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11311                         "%*s%*s Setting open paren #%" IVdf " to %d\n",
11312                         22, "|    |", (int)(depth * 2 + 1), "",
11313                         (IV)parno, REG_NODE_NUM(ret)));
11314                     RExC_open_parens[parno]= ret;
11315                 }
11316             }
11317             Set_Node_Length(ret, 1); /* MJD */
11318             Set_Node_Offset(ret, RExC_parse); /* MJD */
11319             is_open = 1;
11320         } else {
11321             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11322             paren = ':';
11323             ret = NULL;
11324         }
11325     }
11326     else                        /* ! paren */
11327         ret = NULL;
11328
11329    parse_rest:
11330     /* Pick up the branches, linking them together. */
11331     parse_start = RExC_parse;   /* MJD */
11332     br = regbranch(pRExC_state, &flags, 1,depth+1);
11333
11334     /*     branch_len = (paren != 0); */
11335
11336     if (br == NULL) {
11337         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11338             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11339             return NULL;
11340         }
11341         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11342     }
11343     if (*RExC_parse == '|') {
11344         if (!SIZE_ONLY && RExC_extralen) {
11345             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11346         }
11347         else {                  /* MJD */
11348             reginsert(pRExC_state, BRANCH, br, depth+1);
11349             Set_Node_Length(br, paren != 0);
11350             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11351         }
11352         have_branch = 1;
11353         if (SIZE_ONLY)
11354             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11355     }
11356     else if (paren == ':') {
11357         *flagp |= flags&SIMPLE;
11358     }
11359     if (is_open) {                              /* Starts with OPEN. */
11360         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11361     }
11362     else if (paren != '?')              /* Not Conditional */
11363         ret = br;
11364     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11365     lastbr = br;
11366     while (*RExC_parse == '|') {
11367         if (!SIZE_ONLY && RExC_extralen) {
11368             ender = reganode(pRExC_state, LONGJMP,0);
11369
11370             /* Append to the previous. */
11371             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11372         }
11373         if (SIZE_ONLY)
11374             RExC_extralen += 2;         /* Account for LONGJMP. */
11375         nextchar(pRExC_state);
11376         if (freeze_paren) {
11377             if (RExC_npar > after_freeze)
11378                 after_freeze = RExC_npar;
11379             RExC_npar = freeze_paren;
11380         }
11381         br = regbranch(pRExC_state, &flags, 0, depth+1);
11382
11383         if (br == NULL) {
11384             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11385                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11386                 return NULL;
11387             }
11388             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11389         }
11390         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11391         lastbr = br;
11392         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11393     }
11394
11395     if (have_branch || paren != ':') {
11396         /* Make a closing node, and hook it on the end. */
11397         switch (paren) {
11398         case ':':
11399             ender = reg_node(pRExC_state, TAIL);
11400             break;
11401         case 1: case 2:
11402             ender = reganode(pRExC_state, CLOSE, parno);
11403             if ( RExC_close_parens ) {
11404                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11405                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
11406                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11407                 RExC_close_parens[parno]= ender;
11408                 if (RExC_nestroot == parno)
11409                     RExC_nestroot = 0;
11410             }
11411             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11412             Set_Node_Length(ender,1); /* MJD */
11413             break;
11414         case '<':
11415         case ',':
11416         case '=':
11417         case '!':
11418             *flagp &= ~HASWIDTH;
11419             /* FALLTHROUGH */
11420         case '>':
11421             ender = reg_node(pRExC_state, SUCCEED);
11422             break;
11423         case 0:
11424             ender = reg_node(pRExC_state, END);
11425             if (!SIZE_ONLY) {
11426                 assert(!RExC_end_op); /* there can only be one! */
11427                 RExC_end_op = ender;
11428                 if (RExC_close_parens) {
11429                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11430                         "%*s%*s Setting close paren #0 (END) to %d\n",
11431                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11432
11433                     RExC_close_parens[0]= ender;
11434                 }
11435             }
11436             break;
11437         }
11438         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11439             DEBUG_PARSE_MSG("lsbr");
11440             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11441             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11442             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11443                           SvPV_nolen_const(RExC_mysv1),
11444                           (IV)REG_NODE_NUM(lastbr),
11445                           SvPV_nolen_const(RExC_mysv2),
11446                           (IV)REG_NODE_NUM(ender),
11447                           (IV)(ender - lastbr)
11448             );
11449         });
11450         REGTAIL(pRExC_state, lastbr, ender);
11451
11452         if (have_branch && !SIZE_ONLY) {
11453             char is_nothing= 1;
11454             if (depth==1)
11455                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11456
11457             /* Hook the tails of the branches to the closing node. */
11458             for (br = ret; br; br = regnext(br)) {
11459                 const U8 op = PL_regkind[OP(br)];
11460                 if (op == BRANCH) {
11461                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11462                     if ( OP(NEXTOPER(br)) != NOTHING
11463                          || regnext(NEXTOPER(br)) != ender)
11464                         is_nothing= 0;
11465                 }
11466                 else if (op == BRANCHJ) {
11467                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11468                     /* for now we always disable this optimisation * /
11469                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11470                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11471                     */
11472                         is_nothing= 0;
11473                 }
11474             }
11475             if (is_nothing) {
11476                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11477                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11478                     DEBUG_PARSE_MSG("NADA");
11479                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11480                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11481                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11482                                   SvPV_nolen_const(RExC_mysv1),
11483                                   (IV)REG_NODE_NUM(ret),
11484                                   SvPV_nolen_const(RExC_mysv2),
11485                                   (IV)REG_NODE_NUM(ender),
11486                                   (IV)(ender - ret)
11487                     );
11488                 });
11489                 OP(br)= NOTHING;
11490                 if (OP(ender) == TAIL) {
11491                     NEXT_OFF(br)= 0;
11492                     RExC_emit= br + 1;
11493                 } else {
11494                     regnode *opt;
11495                     for ( opt= br + 1; opt < ender ; opt++ )
11496                         OP(opt)= OPTIMIZED;
11497                     NEXT_OFF(br)= ender - br;
11498                 }
11499             }
11500         }
11501     }
11502
11503     {
11504         const char *p;
11505         static const char parens[] = "=!<,>";
11506
11507         if (paren && (p = strchr(parens, paren))) {
11508             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11509             int flag = (p - parens) > 1;
11510
11511             if (paren == '>')
11512                 node = SUSPEND, flag = 0;
11513             reginsert(pRExC_state, node,ret, depth+1);
11514             Set_Node_Cur_Length(ret, parse_start);
11515             Set_Node_Offset(ret, parse_start + 1);
11516             ret->flags = flag;
11517             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11518         }
11519     }
11520
11521     /* Check for proper termination. */
11522     if (paren) {
11523         /* restore original flags, but keep (?p) and, if we've changed from /d
11524          * rules to /u, keep the /u */
11525         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11526         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11527             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11528         }
11529         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11530             RExC_parse = oregcomp_parse;
11531             vFAIL("Unmatched (");
11532         }
11533         nextchar(pRExC_state);
11534     }
11535     else if (!paren && RExC_parse < RExC_end) {
11536         if (*RExC_parse == ')') {
11537             RExC_parse++;
11538             vFAIL("Unmatched )");
11539         }
11540         else
11541             FAIL("Junk on end of regexp");      /* "Can't happen". */
11542         NOT_REACHED; /* NOTREACHED */
11543     }
11544
11545     if (RExC_in_lookbehind) {
11546         RExC_in_lookbehind--;
11547     }
11548     if (after_freeze > RExC_npar)
11549         RExC_npar = after_freeze;
11550     return(ret);
11551 }
11552
11553 /*
11554  - regbranch - one alternative of an | operator
11555  *
11556  * Implements the concatenation operator.
11557  *
11558  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11559  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11560  */
11561 STATIC regnode *
11562 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11563 {
11564     regnode *ret;
11565     regnode *chain = NULL;
11566     regnode *latest;
11567     I32 flags = 0, c = 0;
11568     GET_RE_DEBUG_FLAGS_DECL;
11569
11570     PERL_ARGS_ASSERT_REGBRANCH;
11571
11572     DEBUG_PARSE("brnc");
11573
11574     if (first)
11575         ret = NULL;
11576     else {
11577         if (!SIZE_ONLY && RExC_extralen)
11578             ret = reganode(pRExC_state, BRANCHJ,0);
11579         else {
11580             ret = reg_node(pRExC_state, BRANCH);
11581             Set_Node_Length(ret, 1);
11582         }
11583     }
11584
11585     if (!first && SIZE_ONLY)
11586         RExC_extralen += 1;                     /* BRANCHJ */
11587
11588     *flagp = WORST;                     /* Tentatively. */
11589
11590     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11591                             FALSE /* Don't force to /x */ );
11592     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11593         flags &= ~TRYAGAIN;
11594         latest = regpiece(pRExC_state, &flags,depth+1);
11595         if (latest == NULL) {
11596             if (flags & TRYAGAIN)
11597                 continue;
11598             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11599                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11600                 return NULL;
11601             }
11602             FAIL2("panic: regpiece returned NULL, flags=%#" UVxf, (UV) flags);
11603         }
11604         else if (ret == NULL)
11605             ret = latest;
11606         *flagp |= flags&(HASWIDTH|POSTPONED);
11607         if (chain == NULL)      /* First piece. */
11608             *flagp |= flags&SPSTART;
11609         else {
11610             /* FIXME adding one for every branch after the first is probably
11611              * excessive now we have TRIE support. (hv) */
11612             MARK_NAUGHTY(1);
11613             REGTAIL(pRExC_state, chain, latest);
11614         }
11615         chain = latest;
11616         c++;
11617     }
11618     if (chain == NULL) {        /* Loop ran zero times. */
11619         chain = reg_node(pRExC_state, NOTHING);
11620         if (ret == NULL)
11621             ret = chain;
11622     }
11623     if (c == 1) {
11624         *flagp |= flags&SIMPLE;
11625     }
11626
11627     return ret;
11628 }
11629
11630 /*
11631  - regpiece - something followed by possible quantifier * + ? {n,m}
11632  *
11633  * Note that the branching code sequences used for ? and the general cases
11634  * of * and + are somewhat optimized:  they use the same NOTHING node as
11635  * both the endmarker for their branch list and the body of the last branch.
11636  * It might seem that this node could be dispensed with entirely, but the
11637  * endmarker role is not redundant.
11638  *
11639  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11640  * TRYAGAIN.
11641  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11642  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11643  */
11644 STATIC regnode *
11645 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11646 {
11647     regnode *ret;
11648     char op;
11649     char *next;
11650     I32 flags;
11651     const char * const origparse = RExC_parse;
11652     I32 min;
11653     I32 max = REG_INFTY;
11654 #ifdef RE_TRACK_PATTERN_OFFSETS
11655     char *parse_start;
11656 #endif
11657     const char *maxpos = NULL;
11658     UV uv;
11659
11660     /* Save the original in case we change the emitted regop to a FAIL. */
11661     regnode * const orig_emit = RExC_emit;
11662
11663     GET_RE_DEBUG_FLAGS_DECL;
11664
11665     PERL_ARGS_ASSERT_REGPIECE;
11666
11667     DEBUG_PARSE("piec");
11668
11669     ret = regatom(pRExC_state, &flags,depth+1);
11670     if (ret == NULL) {
11671         if (flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8))
11672             *flagp |= flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8);
11673         else
11674             FAIL2("panic: regatom returned NULL, flags=%#" UVxf, (UV) flags);
11675         return(NULL);
11676     }
11677
11678     op = *RExC_parse;
11679
11680     if (op == '{' && regcurly(RExC_parse)) {
11681         maxpos = NULL;
11682 #ifdef RE_TRACK_PATTERN_OFFSETS
11683         parse_start = RExC_parse; /* MJD */
11684 #endif
11685         next = RExC_parse + 1;
11686         while (isDIGIT(*next) || *next == ',') {
11687             if (*next == ',') {
11688                 if (maxpos)
11689                     break;
11690                 else
11691                     maxpos = next;
11692             }
11693             next++;
11694         }
11695         if (*next == '}') {             /* got one */
11696             const char* endptr;
11697             if (!maxpos)
11698                 maxpos = next;
11699             RExC_parse++;
11700             if (isDIGIT(*RExC_parse)) {
11701                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
11702                     vFAIL("Invalid quantifier in {,}");
11703                 if (uv >= REG_INFTY)
11704                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11705                 min = (I32)uv;
11706             } else {
11707                 min = 0;
11708             }
11709             if (*maxpos == ',')
11710                 maxpos++;
11711             else
11712                 maxpos = RExC_parse;
11713             if (isDIGIT(*maxpos)) {
11714                 if (!grok_atoUV(maxpos, &uv, &endptr))
11715                     vFAIL("Invalid quantifier in {,}");
11716                 if (uv >= REG_INFTY)
11717                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11718                 max = (I32)uv;
11719             } else {
11720                 max = REG_INFTY;                /* meaning "infinity" */
11721             }
11722             RExC_parse = next;
11723             nextchar(pRExC_state);
11724             if (max < min) {    /* If can't match, warn and optimize to fail
11725                                    unconditionally */
11726                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
11727                 if (PASS2) {
11728                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
11729                     NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
11730                 }
11731                 return ret;
11732             }
11733             else if (min == max && *RExC_parse == '?')
11734             {
11735                 if (PASS2) {
11736                     ckWARN2reg(RExC_parse + 1,
11737                                "Useless use of greediness modifier '%c'",
11738                                *RExC_parse);
11739                 }
11740             }
11741
11742           do_curly:
11743             if ((flags&SIMPLE)) {
11744                 if (min == 0 && max == REG_INFTY) {
11745                     reginsert(pRExC_state, STAR, ret, depth+1);
11746                     ret->flags = 0;
11747                     MARK_NAUGHTY(4);
11748                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11749                     goto nest_check;
11750                 }
11751                 if (min == 1 && max == REG_INFTY) {
11752                     reginsert(pRExC_state, PLUS, ret, depth+1);
11753                     ret->flags = 0;
11754                     MARK_NAUGHTY(3);
11755                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11756                     goto nest_check;
11757                 }
11758                 MARK_NAUGHTY_EXP(2, 2);
11759                 reginsert(pRExC_state, CURLY, ret, depth+1);
11760                 Set_Node_Offset(ret, parse_start+1); /* MJD */
11761                 Set_Node_Cur_Length(ret, parse_start);
11762             }
11763             else {
11764                 regnode * const w = reg_node(pRExC_state, WHILEM);
11765
11766                 w->flags = 0;
11767                 REGTAIL(pRExC_state, ret, w);
11768                 if (!SIZE_ONLY && RExC_extralen) {
11769                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
11770                     reginsert(pRExC_state, NOTHING,ret, depth+1);
11771                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
11772                 }
11773                 reginsert(pRExC_state, CURLYX,ret, depth+1);
11774                                 /* MJD hk */
11775                 Set_Node_Offset(ret, parse_start+1);
11776                 Set_Node_Length(ret,
11777                                 op == '{' ? (RExC_parse - parse_start) : 1);
11778
11779                 if (!SIZE_ONLY && RExC_extralen)
11780                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
11781                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
11782                 if (SIZE_ONLY)
11783                     RExC_whilem_seen++, RExC_extralen += 3;
11784                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
11785             }
11786             ret->flags = 0;
11787
11788             if (min > 0)
11789                 *flagp = WORST;
11790             if (max > 0)
11791                 *flagp |= HASWIDTH;
11792             if (!SIZE_ONLY) {
11793                 ARG1_SET(ret, (U16)min);
11794                 ARG2_SET(ret, (U16)max);
11795             }
11796             if (max == REG_INFTY)
11797                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11798
11799             goto nest_check;
11800         }
11801     }
11802
11803     if (!ISMULT1(op)) {
11804         *flagp = flags;
11805         return(ret);
11806     }
11807
11808 #if 0                           /* Now runtime fix should be reliable. */
11809
11810     /* if this is reinstated, don't forget to put this back into perldiag:
11811
11812             =item Regexp *+ operand could be empty at {#} in regex m/%s/
11813
11814            (F) The part of the regexp subject to either the * or + quantifier
11815            could match an empty string. The {#} shows in the regular
11816            expression about where the problem was discovered.
11817
11818     */
11819
11820     if (!(flags&HASWIDTH) && op != '?')
11821       vFAIL("Regexp *+ operand could be empty");
11822 #endif
11823
11824 #ifdef RE_TRACK_PATTERN_OFFSETS
11825     parse_start = RExC_parse;
11826 #endif
11827     nextchar(pRExC_state);
11828
11829     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
11830
11831     if (op == '*') {
11832         min = 0;
11833         goto do_curly;
11834     }
11835     else if (op == '+') {
11836         min = 1;
11837         goto do_curly;
11838     }
11839     else if (op == '?') {
11840         min = 0; max = 1;
11841         goto do_curly;
11842     }
11843   nest_check:
11844     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
11845         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11846         ckWARN2reg(RExC_parse,
11847                    "%" UTF8f " matches null string many times",
11848                    UTF8fARG(UTF, (RExC_parse >= origparse
11849                                  ? RExC_parse - origparse
11850                                  : 0),
11851                    origparse));
11852         (void)ReREFCNT_inc(RExC_rx_sv);
11853     }
11854
11855     if (*RExC_parse == '?') {
11856         nextchar(pRExC_state);
11857         reginsert(pRExC_state, MINMOD, ret, depth+1);
11858         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11859     }
11860     else if (*RExC_parse == '+') {
11861         regnode *ender;
11862         nextchar(pRExC_state);
11863         ender = reg_node(pRExC_state, SUCCEED);
11864         REGTAIL(pRExC_state, ret, ender);
11865         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11866         ret->flags = 0;
11867         ender = reg_node(pRExC_state, TAIL);
11868         REGTAIL(pRExC_state, ret, ender);
11869     }
11870
11871     if (ISMULT2(RExC_parse)) {
11872         RExC_parse++;
11873         vFAIL("Nested quantifiers");
11874     }
11875
11876     return(ret);
11877 }
11878
11879 STATIC bool
11880 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11881                 regnode ** node_p,
11882                 UV * code_point_p,
11883                 int * cp_count,
11884                 I32 * flagp,
11885                 const bool strict,
11886                 const U32 depth
11887     )
11888 {
11889  /* This routine teases apart the various meanings of \N and returns
11890   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11891   * in the current context.
11892   *
11893   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11894   *
11895   * If <code_point_p> is not NULL, the context is expecting the result to be a
11896   * single code point.  If this \N instance turns out to a single code point,
11897   * the function returns TRUE and sets *code_point_p to that code point.
11898   *
11899   * If <node_p> is not NULL, the context is expecting the result to be one of
11900   * the things representable by a regnode.  If this \N instance turns out to be
11901   * one such, the function generates the regnode, returns TRUE and sets *node_p
11902   * to point to that regnode.
11903   *
11904   * If this instance of \N isn't legal in any context, this function will
11905   * generate a fatal error and not return.
11906   *
11907   * On input, RExC_parse should point to the first char following the \N at the
11908   * time of the call.  On successful return, RExC_parse will have been updated
11909   * to point to just after the sequence identified by this routine.  Also
11910   * *flagp has been updated as needed.
11911   *
11912   * When there is some problem with the current context and this \N instance,
11913   * the function returns FALSE, without advancing RExC_parse, nor setting
11914   * *node_p, nor *code_point_p, nor *flagp.
11915   *
11916   * If <cp_count> is not NULL, the caller wants to know the length (in code
11917   * points) that this \N sequence matches.  This is set even if the function
11918   * returns FALSE, as detailed below.
11919   *
11920   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11921   *
11922   * Probably the most common case is for the \N to specify a single code point.
11923   * *cp_count will be set to 1, and *code_point_p will be set to that code
11924   * point.
11925   *
11926   * Another possibility is for the input to be an empty \N{}, which for
11927   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11928   * will be set to a generated NOTHING node.
11929   *
11930   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11931   * set to 0. *node_p will be set to a generated REG_ANY node.
11932   *
11933   * The fourth possibility is that \N resolves to a sequence of more than one
11934   * code points.  *cp_count will be set to the number of code points in the
11935   * sequence. *node_p * will be set to a generated node returned by this
11936   * function calling S_reg().
11937   *
11938   * The final possibility is that it is premature to be calling this function;
11939   * that pass1 needs to be restarted.  This can happen when this changes from
11940   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
11941   * latter occurs only when the fourth possibility would otherwise be in
11942   * effect, and is because one of those code points requires the pattern to be
11943   * recompiled as UTF-8.  The function returns FALSE, and sets the
11944   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
11945   * happens, the caller needs to desist from continuing parsing, and return
11946   * this information to its caller.  This is not set for when there is only one
11947   * code point, as this can be called as part of an ANYOF node, and they can
11948   * store above-Latin1 code points without the pattern having to be in UTF-8.
11949   *
11950   * For non-single-quoted regexes, the tokenizer has resolved character and
11951   * sequence names inside \N{...} into their Unicode values, normalizing the
11952   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11953   * hex-represented code points in the sequence.  This is done there because
11954   * the names can vary based on what charnames pragma is in scope at the time,
11955   * so we need a way to take a snapshot of what they resolve to at the time of
11956   * the original parse. [perl #56444].
11957   *
11958   * That parsing is skipped for single-quoted regexes, so we may here get
11959   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11960   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11961   * is legal and handled here.  The code point is Unicode, and has to be
11962   * translated into the native character set for non-ASCII platforms.
11963   */
11964
11965     char * endbrace;    /* points to '}' following the name */
11966     char *endchar;      /* Points to '.' or '}' ending cur char in the input
11967                            stream */
11968     char* p = RExC_parse; /* Temporary */
11969
11970     GET_RE_DEBUG_FLAGS_DECL;
11971
11972     PERL_ARGS_ASSERT_GROK_BSLASH_N;
11973
11974     GET_RE_DEBUG_FLAGS;
11975
11976     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
11977     assert(! (node_p && cp_count));               /* At most 1 should be set */
11978
11979     if (cp_count) {     /* Initialize return for the most common case */
11980         *cp_count = 1;
11981     }
11982
11983     /* The [^\n] meaning of \N ignores spaces and comments under the /x
11984      * modifier.  The other meanings do not, so use a temporary until we find
11985      * out which we are being called with */
11986     skip_to_be_ignored_text(pRExC_state, &p,
11987                             FALSE /* Don't force to /x */ );
11988
11989     /* Disambiguate between \N meaning a named character versus \N meaning
11990      * [^\n].  The latter is assumed when the {...} following the \N is a legal
11991      * quantifier, or there is no '{' at all */
11992     if (*p != '{' || regcurly(p)) {
11993         RExC_parse = p;
11994         if (cp_count) {
11995             *cp_count = -1;
11996         }
11997
11998         if (! node_p) {
11999             return FALSE;
12000         }
12001
12002         *node_p = reg_node(pRExC_state, REG_ANY);
12003         *flagp |= HASWIDTH|SIMPLE;
12004         MARK_NAUGHTY(1);
12005         Set_Node_Length(*node_p, 1); /* MJD */
12006         return TRUE;
12007     }
12008
12009     /* Here, we have decided it should be a named character or sequence */
12010
12011     /* The test above made sure that the next real character is a '{', but
12012      * under the /x modifier, it could be separated by space (or a comment and
12013      * \n) and this is not allowed (for consistency with \x{...} and the
12014      * tokenizer handling of \N{NAME}). */
12015     if (*RExC_parse != '{') {
12016         vFAIL("Missing braces on \\N{}");
12017     }
12018
12019     RExC_parse++;       /* Skip past the '{' */
12020
12021     if (! (endbrace = strchr(RExC_parse, '}'))) { /* no trailing brace */
12022         vFAIL2("Missing right brace on \\%c{}", 'N');
12023     }
12024     else if(!(endbrace == RExC_parse            /* nothing between the {} */
12025               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
12026                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
12027                                                        error msg) */
12028     {
12029         RExC_parse = endbrace;  /* position msg's '<--HERE' */
12030         vFAIL("\\N{NAME} must be resolved by the lexer");
12031     }
12032
12033     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
12034                                         semantics */
12035
12036     if (endbrace == RExC_parse) {   /* empty: \N{} */
12037         if (strict) {
12038             RExC_parse++;   /* Position after the "}" */
12039             vFAIL("Zero length \\N{}");
12040         }
12041         if (cp_count) {
12042             *cp_count = 0;
12043         }
12044         nextchar(pRExC_state);
12045         if (! node_p) {
12046             return FALSE;
12047         }
12048
12049         *node_p = reg_node(pRExC_state,NOTHING);
12050         return TRUE;
12051     }
12052
12053     RExC_parse += 2;    /* Skip past the 'U+' */
12054
12055     /* Because toke.c has generated a special construct for us guaranteed not
12056      * to have NULs, we can use a str function */
12057     endchar = RExC_parse + strcspn(RExC_parse, ".}");
12058
12059     /* Code points are separated by dots.  If none, there is only one code
12060      * point, and is terminated by the brace */
12061
12062     if (endchar >= endbrace) {
12063         STRLEN length_of_hex;
12064         I32 grok_hex_flags;
12065
12066         /* Here, exactly one code point.  If that isn't what is wanted, fail */
12067         if (! code_point_p) {
12068             RExC_parse = p;
12069             return FALSE;
12070         }
12071
12072         /* Convert code point from hex */
12073         length_of_hex = (STRLEN)(endchar - RExC_parse);
12074         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
12075                            | PERL_SCAN_DISALLOW_PREFIX
12076
12077                              /* No errors in the first pass (See [perl
12078                               * #122671].)  We let the code below find the
12079                               * errors when there are multiple chars. */
12080                            | ((SIZE_ONLY)
12081                               ? PERL_SCAN_SILENT_ILLDIGIT
12082                               : 0);
12083
12084         /* This routine is the one place where both single- and double-quotish
12085          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
12086          * must be converted to native. */
12087         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
12088                                          &length_of_hex,
12089                                          &grok_hex_flags,
12090                                          NULL));
12091
12092         /* The tokenizer should have guaranteed validity, but it's possible to
12093          * bypass it by using single quoting, so check.  Don't do the check
12094          * here when there are multiple chars; we do it below anyway. */
12095         if (length_of_hex == 0
12096             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
12097         {
12098             RExC_parse += length_of_hex;        /* Includes all the valid */
12099             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
12100                             ? UTF8SKIP(RExC_parse)
12101                             : 1;
12102             /* Guard against malformed utf8 */
12103             if (RExC_parse >= endchar) {
12104                 RExC_parse = endchar;
12105             }
12106             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12107         }
12108
12109         RExC_parse = endbrace + 1;
12110         return TRUE;
12111     }
12112     else {  /* Is a multiple character sequence */
12113         SV * substitute_parse;
12114         STRLEN len;
12115         char *orig_end = RExC_end;
12116         char *save_start = RExC_start;
12117         I32 flags;
12118
12119         /* Count the code points, if desired, in the sequence */
12120         if (cp_count) {
12121             *cp_count = 0;
12122             while (RExC_parse < endbrace) {
12123                 /* Point to the beginning of the next character in the sequence. */
12124                 RExC_parse = endchar + 1;
12125                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
12126                 (*cp_count)++;
12127             }
12128         }
12129
12130         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12131          * But don't backup up the pointer if the caller want to know how many
12132          * code points there are (they can then handle things) */
12133         if (! node_p) {
12134             if (! cp_count) {
12135                 RExC_parse = p;
12136             }
12137             return FALSE;
12138         }
12139
12140         /* What is done here is to convert this to a sub-pattern of the form
12141          * \x{char1}\x{char2}...  and then call reg recursively to parse it
12142          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
12143          * while not having to worry about special handling that some code
12144          * points may have. */
12145
12146         substitute_parse = newSVpvs("?:");
12147
12148         while (RExC_parse < endbrace) {
12149
12150             /* Convert to notation the rest of the code understands */
12151             sv_catpv(substitute_parse, "\\x{");
12152             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
12153             sv_catpv(substitute_parse, "}");
12154
12155             /* Point to the beginning of the next character in the sequence. */
12156             RExC_parse = endchar + 1;
12157             endchar = RExC_parse + strcspn(RExC_parse, ".}");
12158
12159         }
12160         sv_catpv(substitute_parse, ")");
12161
12162         RExC_parse = RExC_start = RExC_adjusted_start = SvPV(substitute_parse,
12163                                                              len);
12164
12165         /* Don't allow empty number */
12166         if (len < (STRLEN) 8) {
12167             RExC_parse = endbrace;
12168             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12169         }
12170         RExC_end = RExC_parse + len;
12171
12172         /* The values are Unicode, and therefore not subject to recoding, but
12173          * have to be converted to native on a non-Unicode (meaning non-ASCII)
12174          * platform. */
12175 #ifdef EBCDIC
12176         RExC_recode_x_to_native = 1;
12177 #endif
12178
12179         if (node_p) {
12180             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
12181                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12182                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12183                     return FALSE;
12184                 }
12185                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#" UVxf,
12186                     (UV) flags);
12187             }
12188             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12189         }
12190
12191         /* Restore the saved values */
12192         RExC_start = RExC_adjusted_start = save_start;
12193         RExC_parse = endbrace;
12194         RExC_end = orig_end;
12195 #ifdef EBCDIC
12196         RExC_recode_x_to_native = 0;
12197 #endif
12198
12199         SvREFCNT_dec_NN(substitute_parse);
12200         nextchar(pRExC_state);
12201
12202         return TRUE;
12203     }
12204 }
12205
12206
12207 PERL_STATIC_INLINE U8
12208 S_compute_EXACTish(RExC_state_t *pRExC_state)
12209 {
12210     U8 op;
12211
12212     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12213
12214     if (! FOLD) {
12215         return (LOC)
12216                 ? EXACTL
12217                 : EXACT;
12218     }
12219
12220     op = get_regex_charset(RExC_flags);
12221     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12222         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12223                  been, so there is no hole */
12224     }
12225
12226     return op + EXACTF;
12227 }
12228
12229 PERL_STATIC_INLINE void
12230 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12231                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12232                          bool downgradable)
12233 {
12234     /* This knows the details about sizing an EXACTish node, setting flags for
12235      * it (by setting <*flagp>, and potentially populating it with a single
12236      * character.
12237      *
12238      * If <len> (the length in bytes) is non-zero, this function assumes that
12239      * the node has already been populated, and just does the sizing.  In this
12240      * case <code_point> should be the final code point that has already been
12241      * placed into the node.  This value will be ignored except that under some
12242      * circumstances <*flagp> is set based on it.
12243      *
12244      * If <len> is zero, the function assumes that the node is to contain only
12245      * the single character given by <code_point> and calculates what <len>
12246      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12247      * additionally will populate the node's STRING with <code_point> or its
12248      * fold if folding.
12249      *
12250      * In both cases <*flagp> is appropriately set
12251      *
12252      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12253      * 255, must be folded (the former only when the rules indicate it can
12254      * match 'ss')
12255      *
12256      * When it does the populating, it looks at the flag 'downgradable'.  If
12257      * true with a node that folds, it checks if the single code point
12258      * participates in a fold, and if not downgrades the node to an EXACT.
12259      * This helps the optimizer */
12260
12261     bool len_passed_in = cBOOL(len != 0);
12262     U8 character[UTF8_MAXBYTES_CASE+1];
12263
12264     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12265
12266     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12267      * sizing difference, and is extra work that is thrown away */
12268     if (downgradable && ! PASS2) {
12269         downgradable = FALSE;
12270     }
12271
12272     if (! len_passed_in) {
12273         if (UTF) {
12274             if (UVCHR_IS_INVARIANT(code_point)) {
12275                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12276                     *character = (U8) code_point;
12277                 }
12278                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12279                           ASCII, which isn't the same thing as INVARIANT on
12280                           EBCDIC, but it works there, as the extra invariants
12281                           fold to themselves) */
12282                     *character = toFOLD((U8) code_point);
12283
12284                     /* We can downgrade to an EXACT node if this character
12285                      * isn't a folding one.  Note that this assumes that
12286                      * nothing above Latin1 folds to some other invariant than
12287                      * one of these alphabetics; otherwise we would also have
12288                      * to check:
12289                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12290                      *      || ASCII_FOLD_RESTRICTED))
12291                      */
12292                     if (downgradable && PL_fold[code_point] == code_point) {
12293                         OP(node) = EXACT;
12294                     }
12295                 }
12296                 len = 1;
12297             }
12298             else if (FOLD && (! LOC
12299                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12300             {   /* Folding, and ok to do so now */
12301                 UV folded = _to_uni_fold_flags(
12302                                    code_point,
12303                                    character,
12304                                    &len,
12305                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12306                                                       ? FOLD_FLAGS_NOMIX_ASCII
12307                                                       : 0));
12308                 if (downgradable
12309                     && folded == code_point /* This quickly rules out many
12310                                                cases, avoiding the
12311                                                _invlist_contains_cp() overhead
12312                                                for those.  */
12313                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12314                 {
12315                     OP(node) = (LOC)
12316                                ? EXACTL
12317                                : EXACT;
12318                 }
12319             }
12320             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12321
12322                 /* Not folding this cp, and can output it directly */
12323                 *character = UTF8_TWO_BYTE_HI(code_point);
12324                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12325                 len = 2;
12326             }
12327             else {
12328                 uvchr_to_utf8( character, code_point);
12329                 len = UTF8SKIP(character);
12330             }
12331         } /* Else pattern isn't UTF8.  */
12332         else if (! FOLD) {
12333             *character = (U8) code_point;
12334             len = 1;
12335         } /* Else is folded non-UTF8 */
12336 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12337    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12338                                       || UNICODE_DOT_DOT_VERSION > 0)
12339         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12340 #else
12341         else if (1) {
12342 #endif
12343             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12344              * comments at join_exact()); */
12345             *character = (U8) code_point;
12346             len = 1;
12347
12348             /* Can turn into an EXACT node if we know the fold at compile time,
12349              * and it folds to itself and doesn't particpate in other folds */
12350             if (downgradable
12351                 && ! LOC
12352                 && PL_fold_latin1[code_point] == code_point
12353                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12354                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12355             {
12356                 OP(node) = EXACT;
12357             }
12358         } /* else is Sharp s.  May need to fold it */
12359         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12360             *character = 's';
12361             *(character + 1) = 's';
12362             len = 2;
12363         }
12364         else {
12365             *character = LATIN_SMALL_LETTER_SHARP_S;
12366             len = 1;
12367         }
12368     }
12369
12370     if (SIZE_ONLY) {
12371         RExC_size += STR_SZ(len);
12372     }
12373     else {
12374         RExC_emit += STR_SZ(len);
12375         STR_LEN(node) = len;
12376         if (! len_passed_in) {
12377             Copy((char *) character, STRING(node), len, char);
12378         }
12379     }
12380
12381     *flagp |= HASWIDTH;
12382
12383     /* A single character node is SIMPLE, except for the special-cased SHARP S
12384      * under /di. */
12385     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12386 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12387    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12388                                       || UNICODE_DOT_DOT_VERSION > 0)
12389         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12390             || ! FOLD || ! DEPENDS_SEMANTICS)
12391 #endif
12392     ) {
12393         *flagp |= SIMPLE;
12394     }
12395
12396     /* The OP may not be well defined in PASS1 */
12397     if (PASS2 && OP(node) == EXACTFL) {
12398         RExC_contains_locale = 1;
12399     }
12400 }
12401
12402
12403 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12404  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12405
12406 static I32
12407 S_backref_value(char *p)
12408 {
12409     const char* endptr;
12410     UV val;
12411     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12412         return (I32)val;
12413     return I32_MAX;
12414 }
12415
12416
12417 /*
12418  - regatom - the lowest level
12419
12420    Try to identify anything special at the start of the current parse position.
12421    If there is, then handle it as required. This may involve generating a
12422    single regop, such as for an assertion; or it may involve recursing, such as
12423    to handle a () structure.
12424
12425    If the string doesn't start with something special then we gobble up
12426    as much literal text as we can.  If we encounter a quantifier, we have to
12427    back off the final literal character, as that quantifier applies to just it
12428    and not to the whole string of literals.
12429
12430    Once we have been able to handle whatever type of thing started the
12431    sequence, we return.
12432
12433    Note: we have to be careful with escapes, as they can be both literal
12434    and special, and in the case of \10 and friends, context determines which.
12435
12436    A summary of the code structure is:
12437
12438    switch (first_byte) {
12439         cases for each special:
12440             handle this special;
12441             break;
12442         case '\\':
12443             switch (2nd byte) {
12444                 cases for each unambiguous special:
12445                     handle this special;
12446                     break;
12447                 cases for each ambigous special/literal:
12448                     disambiguate;
12449                     if (special)  handle here
12450                     else goto defchar;
12451                 default: // unambiguously literal:
12452                     goto defchar;
12453             }
12454         default:  // is a literal char
12455             // FALL THROUGH
12456         defchar:
12457             create EXACTish node for literal;
12458             while (more input and node isn't full) {
12459                 switch (input_byte) {
12460                    cases for each special;
12461                        make sure parse pointer is set so that the next call to
12462                            regatom will see this special first
12463                        goto loopdone; // EXACTish node terminated by prev. char
12464                    default:
12465                        append char to EXACTISH node;
12466                 }
12467                 get next input byte;
12468             }
12469         loopdone:
12470    }
12471    return the generated node;
12472
12473    Specifically there are two separate switches for handling
12474    escape sequences, with the one for handling literal escapes requiring
12475    a dummy entry for all of the special escapes that are actually handled
12476    by the other.
12477
12478    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12479    TRYAGAIN.
12480    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12481    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12482    Otherwise does not return NULL.
12483 */
12484
12485 STATIC regnode *
12486 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12487 {
12488     regnode *ret = NULL;
12489     I32 flags = 0;
12490     char *parse_start;
12491     U8 op;
12492     int invert = 0;
12493     U8 arg;
12494
12495     GET_RE_DEBUG_FLAGS_DECL;
12496
12497     *flagp = WORST;             /* Tentatively. */
12498
12499     DEBUG_PARSE("atom");
12500
12501     PERL_ARGS_ASSERT_REGATOM;
12502
12503   tryagain:
12504     parse_start = RExC_parse;
12505     assert(RExC_parse < RExC_end);
12506     switch ((U8)*RExC_parse) {
12507     case '^':
12508         RExC_seen_zerolen++;
12509         nextchar(pRExC_state);
12510         if (RExC_flags & RXf_PMf_MULTILINE)
12511             ret = reg_node(pRExC_state, MBOL);
12512         else
12513             ret = reg_node(pRExC_state, SBOL);
12514         Set_Node_Length(ret, 1); /* MJD */
12515         break;
12516     case '$':
12517         nextchar(pRExC_state);
12518         if (*RExC_parse)
12519             RExC_seen_zerolen++;
12520         if (RExC_flags & RXf_PMf_MULTILINE)
12521             ret = reg_node(pRExC_state, MEOL);
12522         else
12523             ret = reg_node(pRExC_state, SEOL);
12524         Set_Node_Length(ret, 1); /* MJD */
12525         break;
12526     case '.':
12527         nextchar(pRExC_state);
12528         if (RExC_flags & RXf_PMf_SINGLELINE)
12529             ret = reg_node(pRExC_state, SANY);
12530         else
12531             ret = reg_node(pRExC_state, REG_ANY);
12532         *flagp |= HASWIDTH|SIMPLE;
12533         MARK_NAUGHTY(1);
12534         Set_Node_Length(ret, 1); /* MJD */
12535         break;
12536     case '[':
12537     {
12538         char * const oregcomp_parse = ++RExC_parse;
12539         ret = regclass(pRExC_state, flagp,depth+1,
12540                        FALSE, /* means parse the whole char class */
12541                        TRUE, /* allow multi-char folds */
12542                        FALSE, /* don't silence non-portable warnings. */
12543                        (bool) RExC_strict,
12544                        TRUE, /* Allow an optimized regnode result */
12545                        NULL,
12546                        NULL);
12547         if (ret == NULL) {
12548             if (*flagp & (RESTART_PASS1|NEED_UTF8))
12549                 return NULL;
12550             FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12551                   (UV) *flagp);
12552         }
12553         if (*RExC_parse != ']') {
12554             RExC_parse = oregcomp_parse;
12555             vFAIL("Unmatched [");
12556         }
12557         nextchar(pRExC_state);
12558         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12559         break;
12560     }
12561     case '(':
12562         nextchar(pRExC_state);
12563         ret = reg(pRExC_state, 2, &flags,depth+1);
12564         if (ret == NULL) {
12565                 if (flags & TRYAGAIN) {
12566                     if (RExC_parse >= RExC_end) {
12567                          /* Make parent create an empty node if needed. */
12568                         *flagp |= TRYAGAIN;
12569                         return(NULL);
12570                     }
12571                     goto tryagain;
12572                 }
12573                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12574                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12575                     return NULL;
12576                 }
12577                 FAIL2("panic: reg returned NULL to regatom, flags=%#" UVxf,
12578                                                                  (UV) flags);
12579         }
12580         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12581         break;
12582     case '|':
12583     case ')':
12584         if (flags & TRYAGAIN) {
12585             *flagp |= TRYAGAIN;
12586             return NULL;
12587         }
12588         vFAIL("Internal urp");
12589                                 /* Supposed to be caught earlier. */
12590         break;
12591     case '?':
12592     case '+':
12593     case '*':
12594         RExC_parse++;
12595         vFAIL("Quantifier follows nothing");
12596         break;
12597     case '\\':
12598         /* Special Escapes
12599
12600            This switch handles escape sequences that resolve to some kind
12601            of special regop and not to literal text. Escape sequnces that
12602            resolve to literal text are handled below in the switch marked
12603            "Literal Escapes".
12604
12605            Every entry in this switch *must* have a corresponding entry
12606            in the literal escape switch. However, the opposite is not
12607            required, as the default for this switch is to jump to the
12608            literal text handling code.
12609         */
12610         RExC_parse++;
12611         switch ((U8)*RExC_parse) {
12612         /* Special Escapes */
12613         case 'A':
12614             RExC_seen_zerolen++;
12615             ret = reg_node(pRExC_state, SBOL);
12616             /* SBOL is shared with /^/ so we set the flags so we can tell
12617              * /\A/ from /^/ in split. We check ret because first pass we
12618              * have no regop struct to set the flags on. */
12619             if (PASS2)
12620                 ret->flags = 1;
12621             *flagp |= SIMPLE;
12622             goto finish_meta_pat;
12623         case 'G':
12624             ret = reg_node(pRExC_state, GPOS);
12625             RExC_seen |= REG_GPOS_SEEN;
12626             *flagp |= SIMPLE;
12627             goto finish_meta_pat;
12628         case 'K':
12629             RExC_seen_zerolen++;
12630             ret = reg_node(pRExC_state, KEEPS);
12631             *flagp |= SIMPLE;
12632             /* XXX:dmq : disabling in-place substitution seems to
12633              * be necessary here to avoid cases of memory corruption, as
12634              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
12635              */
12636             RExC_seen |= REG_LOOKBEHIND_SEEN;
12637             goto finish_meta_pat;
12638         case 'Z':
12639             ret = reg_node(pRExC_state, SEOL);
12640             *flagp |= SIMPLE;
12641             RExC_seen_zerolen++;                /* Do not optimize RE away */
12642             goto finish_meta_pat;
12643         case 'z':
12644             ret = reg_node(pRExC_state, EOS);
12645             *flagp |= SIMPLE;
12646             RExC_seen_zerolen++;                /* Do not optimize RE away */
12647             goto finish_meta_pat;
12648         case 'C':
12649             vFAIL("\\C no longer supported");
12650         case 'X':
12651             ret = reg_node(pRExC_state, CLUMP);
12652             *flagp |= HASWIDTH;
12653             goto finish_meta_pat;
12654
12655         case 'W':
12656             invert = 1;
12657             /* FALLTHROUGH */
12658         case 'w':
12659             arg = ANYOF_WORDCHAR;
12660             goto join_posix;
12661
12662         case 'B':
12663             invert = 1;
12664             /* FALLTHROUGH */
12665         case 'b':
12666           {
12667             regex_charset charset = get_regex_charset(RExC_flags);
12668
12669             RExC_seen_zerolen++;
12670             RExC_seen |= REG_LOOKBEHIND_SEEN;
12671             op = BOUND + charset;
12672
12673             if (op == BOUNDL) {
12674                 RExC_contains_locale = 1;
12675             }
12676
12677             ret = reg_node(pRExC_state, op);
12678             *flagp |= SIMPLE;
12679             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
12680                 FLAGS(ret) = TRADITIONAL_BOUND;
12681                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
12682                     OP(ret) = BOUNDA;
12683                 }
12684             }
12685             else {
12686                 STRLEN length;
12687                 char name = *RExC_parse;
12688                 char * endbrace;
12689                 RExC_parse += 2;
12690                 endbrace = strchr(RExC_parse, '}');
12691
12692                 if (! endbrace) {
12693                     vFAIL2("Missing right brace on \\%c{}", name);
12694                 }
12695                 /* XXX Need to decide whether to take spaces or not.  Should be
12696                  * consistent with \p{}, but that currently is SPACE, which
12697                  * means vertical too, which seems wrong
12698                  * while (isBLANK(*RExC_parse)) {
12699                     RExC_parse++;
12700                 }*/
12701                 if (endbrace == RExC_parse) {
12702                     RExC_parse++;  /* After the '}' */
12703                     vFAIL2("Empty \\%c{}", name);
12704                 }
12705                 length = endbrace - RExC_parse;
12706                 /*while (isBLANK(*(RExC_parse + length - 1))) {
12707                     length--;
12708                 }*/
12709                 switch (*RExC_parse) {
12710                     case 'g':
12711                         if (length != 1
12712                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
12713                         {
12714                             goto bad_bound_type;
12715                         }
12716                         FLAGS(ret) = GCB_BOUND;
12717                         break;
12718                     case 'l':
12719                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12720                             goto bad_bound_type;
12721                         }
12722                         FLAGS(ret) = LB_BOUND;
12723                         break;
12724                     case 's':
12725                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12726                             goto bad_bound_type;
12727                         }
12728                         FLAGS(ret) = SB_BOUND;
12729                         break;
12730                     case 'w':
12731                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12732                             goto bad_bound_type;
12733                         }
12734                         FLAGS(ret) = WB_BOUND;
12735                         break;
12736                     default:
12737                       bad_bound_type:
12738                         RExC_parse = endbrace;
12739                         vFAIL2utf8f(
12740                             "'%" UTF8f "' is an unknown bound type",
12741                             UTF8fARG(UTF, length, endbrace - length));
12742                         NOT_REACHED; /*NOTREACHED*/
12743                 }
12744                 RExC_parse = endbrace;
12745                 REQUIRE_UNI_RULES(flagp, NULL);
12746
12747                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
12748                     OP(ret) = BOUNDU;
12749                     length += 4;
12750
12751                     /* Don't have to worry about UTF-8, in this message because
12752                      * to get here the contents of the \b must be ASCII */
12753                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
12754                               "Using /u for '%.*s' instead of /%s",
12755                               (unsigned) length,
12756                               endbrace - length + 1,
12757                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
12758                               ? ASCII_RESTRICT_PAT_MODS
12759                               : ASCII_MORE_RESTRICT_PAT_MODS);
12760                 }
12761             }
12762
12763             if (PASS2 && invert) {
12764                 OP(ret) += NBOUND - BOUND;
12765             }
12766             goto finish_meta_pat;
12767           }
12768
12769         case 'D':
12770             invert = 1;
12771             /* FALLTHROUGH */
12772         case 'd':
12773             arg = ANYOF_DIGIT;
12774             if (! DEPENDS_SEMANTICS) {
12775                 goto join_posix;
12776             }
12777
12778             /* \d doesn't have any matches in the upper Latin1 range, hence /d
12779              * is equivalent to /u.  Changing to /u saves some branches at
12780              * runtime */
12781             op = POSIXU;
12782             goto join_posix_op_known;
12783
12784         case 'R':
12785             ret = reg_node(pRExC_state, LNBREAK);
12786             *flagp |= HASWIDTH|SIMPLE;
12787             goto finish_meta_pat;
12788
12789         case 'H':
12790             invert = 1;
12791             /* FALLTHROUGH */
12792         case 'h':
12793             arg = ANYOF_BLANK;
12794             op = POSIXU;
12795             goto join_posix_op_known;
12796
12797         case 'V':
12798             invert = 1;
12799             /* FALLTHROUGH */
12800         case 'v':
12801             arg = ANYOF_VERTWS;
12802             op = POSIXU;
12803             goto join_posix_op_known;
12804
12805         case 'S':
12806             invert = 1;
12807             /* FALLTHROUGH */
12808         case 's':
12809             arg = ANYOF_SPACE;
12810
12811           join_posix:
12812
12813             op = POSIXD + get_regex_charset(RExC_flags);
12814             if (op > POSIXA) {  /* /aa is same as /a */
12815                 op = POSIXA;
12816             }
12817             else if (op == POSIXL) {
12818                 RExC_contains_locale = 1;
12819             }
12820
12821           join_posix_op_known:
12822
12823             if (invert) {
12824                 op += NPOSIXD - POSIXD;
12825             }
12826
12827             ret = reg_node(pRExC_state, op);
12828             if (! SIZE_ONLY) {
12829                 FLAGS(ret) = namedclass_to_classnum(arg);
12830             }
12831
12832             *flagp |= HASWIDTH|SIMPLE;
12833             /* FALLTHROUGH */
12834
12835           finish_meta_pat:
12836             nextchar(pRExC_state);
12837             Set_Node_Length(ret, 2); /* MJD */
12838             break;
12839         case 'p':
12840         case 'P':
12841             RExC_parse--;
12842
12843             ret = regclass(pRExC_state, flagp,depth+1,
12844                            TRUE, /* means just parse this element */
12845                            FALSE, /* don't allow multi-char folds */
12846                            FALSE, /* don't silence non-portable warnings.  It
12847                                      would be a bug if these returned
12848                                      non-portables */
12849                            (bool) RExC_strict,
12850                            TRUE, /* Allow an optimized regnode result */
12851                            NULL,
12852                            NULL);
12853             if (*flagp & RESTART_PASS1)
12854                 return NULL;
12855             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
12856              * multi-char folds are allowed.  */
12857             if (!ret)
12858                 FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12859                       (UV) *flagp);
12860
12861             RExC_parse--;
12862
12863             Set_Node_Offset(ret, parse_start);
12864             Set_Node_Cur_Length(ret, parse_start - 2);
12865             nextchar(pRExC_state);
12866             break;
12867         case 'N':
12868             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12869              * \N{...} evaluates to a sequence of more than one code points).
12870              * The function call below returns a regnode, which is our result.
12871              * The parameters cause it to fail if the \N{} evaluates to a
12872              * single code point; we handle those like any other literal.  The
12873              * reason that the multicharacter case is handled here and not as
12874              * part of the EXACtish code is because of quantifiers.  In
12875              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12876              * this way makes that Just Happen. dmq.
12877              * join_exact() will join this up with adjacent EXACTish nodes
12878              * later on, if appropriate. */
12879             ++RExC_parse;
12880             if (grok_bslash_N(pRExC_state,
12881                               &ret,     /* Want a regnode returned */
12882                               NULL,     /* Fail if evaluates to a single code
12883                                            point */
12884                               NULL,     /* Don't need a count of how many code
12885                                            points */
12886                               flagp,
12887                               RExC_strict,
12888                               depth)
12889             ) {
12890                 break;
12891             }
12892
12893             if (*flagp & RESTART_PASS1)
12894                 return NULL;
12895
12896             /* Here, evaluates to a single code point.  Go get that */
12897             RExC_parse = parse_start;
12898             goto defchar;
12899
12900         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12901       parse_named_seq:
12902         {
12903             char ch;
12904             if (   RExC_parse >= RExC_end - 1
12905                 || ((   ch = RExC_parse[1]) != '<'
12906                                       && ch != '\''
12907                                       && ch != '{'))
12908             {
12909                 RExC_parse++;
12910                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12911                 vFAIL2("Sequence %.2s... not terminated",parse_start);
12912             } else {
12913                 RExC_parse += 2;
12914                 ret = handle_named_backref(pRExC_state,
12915                                            flagp,
12916                                            parse_start,
12917                                            (ch == '<')
12918                                            ? '>'
12919                                            : (ch == '{')
12920                                              ? '}'
12921                                              : '\'');
12922             }
12923             break;
12924         }
12925         case 'g':
12926         case '1': case '2': case '3': case '4':
12927         case '5': case '6': case '7': case '8': case '9':
12928             {
12929                 I32 num;
12930                 bool hasbrace = 0;
12931
12932                 if (*RExC_parse == 'g') {
12933                     bool isrel = 0;
12934
12935                     RExC_parse++;
12936                     if (*RExC_parse == '{') {
12937                         RExC_parse++;
12938                         hasbrace = 1;
12939                     }
12940                     if (*RExC_parse == '-') {
12941                         RExC_parse++;
12942                         isrel = 1;
12943                     }
12944                     if (hasbrace && !isDIGIT(*RExC_parse)) {
12945                         if (isrel) RExC_parse--;
12946                         RExC_parse -= 2;
12947                         goto parse_named_seq;
12948                     }
12949
12950                     if (RExC_parse >= RExC_end) {
12951                         goto unterminated_g;
12952                     }
12953                     num = S_backref_value(RExC_parse);
12954                     if (num == 0)
12955                         vFAIL("Reference to invalid group 0");
12956                     else if (num == I32_MAX) {
12957                          if (isDIGIT(*RExC_parse))
12958                             vFAIL("Reference to nonexistent group");
12959                         else
12960                           unterminated_g:
12961                             vFAIL("Unterminated \\g... pattern");
12962                     }
12963
12964                     if (isrel) {
12965                         num = RExC_npar - num;
12966                         if (num < 1)
12967                             vFAIL("Reference to nonexistent or unclosed group");
12968                     }
12969                 }
12970                 else {
12971                     num = S_backref_value(RExC_parse);
12972                     /* bare \NNN might be backref or octal - if it is larger
12973                      * than or equal RExC_npar then it is assumed to be an
12974                      * octal escape. Note RExC_npar is +1 from the actual
12975                      * number of parens. */
12976                     /* Note we do NOT check if num == I32_MAX here, as that is
12977                      * handled by the RExC_npar check */
12978
12979                     if (
12980                         /* any numeric escape < 10 is always a backref */
12981                         num > 9
12982                         /* any numeric escape < RExC_npar is a backref */
12983                         && num >= RExC_npar
12984                         /* cannot be an octal escape if it starts with 8 */
12985                         && *RExC_parse != '8'
12986                         /* cannot be an octal escape it it starts with 9 */
12987                         && *RExC_parse != '9'
12988                     )
12989                     {
12990                         /* Probably not a backref, instead likely to be an
12991                          * octal character escape, e.g. \35 or \777.
12992                          * The above logic should make it obvious why using
12993                          * octal escapes in patterns is problematic. - Yves */
12994                         RExC_parse = parse_start;
12995                         goto defchar;
12996                     }
12997                 }
12998
12999                 /* At this point RExC_parse points at a numeric escape like
13000                  * \12 or \88 or something similar, which we should NOT treat
13001                  * as an octal escape. It may or may not be a valid backref
13002                  * escape. For instance \88888888 is unlikely to be a valid
13003                  * backref. */
13004                 while (isDIGIT(*RExC_parse))
13005                     RExC_parse++;
13006                 if (hasbrace) {
13007                     if (*RExC_parse != '}')
13008                         vFAIL("Unterminated \\g{...} pattern");
13009                     RExC_parse++;
13010                 }
13011                 if (!SIZE_ONLY) {
13012                     if (num > (I32)RExC_rx->nparens)
13013                         vFAIL("Reference to nonexistent group");
13014                 }
13015                 RExC_sawback = 1;
13016                 ret = reganode(pRExC_state,
13017                                ((! FOLD)
13018                                  ? REF
13019                                  : (ASCII_FOLD_RESTRICTED)
13020                                    ? REFFA
13021                                    : (AT_LEAST_UNI_SEMANTICS)
13022                                      ? REFFU
13023                                      : (LOC)
13024                                        ? REFFL
13025                                        : REFF),
13026                                 num);
13027                 *flagp |= HASWIDTH;
13028
13029                 /* override incorrect value set in reganode MJD */
13030                 Set_Node_Offset(ret, parse_start);
13031                 Set_Node_Cur_Length(ret, parse_start-1);
13032                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13033                                         FALSE /* Don't force to /x */ );
13034             }
13035             break;
13036         case '\0':
13037             if (RExC_parse >= RExC_end)
13038                 FAIL("Trailing \\");
13039             /* FALLTHROUGH */
13040         default:
13041             /* Do not generate "unrecognized" warnings here, we fall
13042                back into the quick-grab loop below */
13043             RExC_parse = parse_start;
13044             goto defchar;
13045         } /* end of switch on a \foo sequence */
13046         break;
13047
13048     case '#':
13049
13050         /* '#' comments should have been spaced over before this function was
13051          * called */
13052         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13053         /*
13054         if (RExC_flags & RXf_PMf_EXTENDED) {
13055             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13056             if (RExC_parse < RExC_end)
13057                 goto tryagain;
13058         }
13059         */
13060
13061         /* FALLTHROUGH */
13062
13063     default:
13064           defchar: {
13065
13066             /* Here, we have determined that the next thing is probably a
13067              * literal character.  RExC_parse points to the first byte of its
13068              * definition.  (It still may be an escape sequence that evaluates
13069              * to a single character) */
13070
13071             STRLEN len = 0;
13072             UV ender = 0;
13073             char *p;
13074             char *s;
13075 #define MAX_NODE_STRING_SIZE 127
13076             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
13077             char *s0;
13078             U8 upper_parse = MAX_NODE_STRING_SIZE;
13079             U8 node_type = compute_EXACTish(pRExC_state);
13080             bool next_is_quantifier;
13081             char * oldp = NULL;
13082
13083             /* We can convert EXACTF nodes to EXACTFU if they contain only
13084              * characters that match identically regardless of the target
13085              * string's UTF8ness.  The reason to do this is that EXACTF is not
13086              * trie-able, EXACTFU is.
13087              *
13088              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13089              * contain only above-Latin1 characters (hence must be in UTF8),
13090              * which don't participate in folds with Latin1-range characters,
13091              * as the latter's folds aren't known until runtime.  (We don't
13092              * need to figure this out until pass 2) */
13093             bool maybe_exactfu = PASS2
13094                                && (node_type == EXACTF || node_type == EXACTFL);
13095
13096             /* If a folding node contains only code points that don't
13097              * participate in folds, it can be changed into an EXACT node,
13098              * which allows the optimizer more things to look for */
13099             bool maybe_exact;
13100
13101             ret = reg_node(pRExC_state, node_type);
13102
13103             /* In pass1, folded, we use a temporary buffer instead of the
13104              * actual node, as the node doesn't exist yet */
13105             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
13106
13107             s0 = s;
13108
13109           reparse:
13110
13111             /* We look for the EXACTFish to EXACT node optimizaton only if
13112              * folding.  (And we don't need to figure this out until pass 2).
13113              * XXX It might actually make sense to split the node into portions
13114              * that are exact and ones that aren't, so that we could later use
13115              * the exact ones to find the longest fixed and floating strings.
13116              * One would want to join them back into a larger node.  One could
13117              * use a pseudo regnode like 'EXACT_ORIG_FOLD' */
13118             maybe_exact = FOLD && PASS2;
13119
13120             /* XXX The node can hold up to 255 bytes, yet this only goes to
13121              * 127.  I (khw) do not know why.  Keeping it somewhat less than
13122              * 255 allows us to not have to worry about overflow due to
13123              * converting to utf8 and fold expansion, but that value is
13124              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
13125              * split up by this limit into a single one using the real max of
13126              * 255.  Even at 127, this breaks under rare circumstances.  If
13127              * folding, we do not want to split a node at a character that is a
13128              * non-final in a multi-char fold, as an input string could just
13129              * happen to want to match across the node boundary.  The join
13130              * would solve that problem if the join actually happens.  But a
13131              * series of more than two nodes in a row each of 127 would cause
13132              * the first join to succeed to get to 254, but then there wouldn't
13133              * be room for the next one, which could at be one of those split
13134              * multi-char folds.  I don't know of any fool-proof solution.  One
13135              * could back off to end with only a code point that isn't such a
13136              * non-final, but it is possible for there not to be any in the
13137              * entire node. */
13138
13139             assert(   ! UTF     /* Is at the beginning of a character */
13140                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13141                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13142
13143             /* Here, we have a literal character.  Find the maximal string of
13144              * them in the input that we can fit into a single EXACTish node.
13145              * We quit at the first non-literal or when the node gets full */
13146             for (p = RExC_parse;
13147                  len < upper_parse && p < RExC_end;
13148                  len++)
13149             {
13150                 oldp = p;
13151
13152                 /* White space has already been ignored */
13153                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13154                        || ! is_PATWS_safe((p), RExC_end, UTF));
13155
13156                 switch ((U8)*p) {
13157                 case '^':
13158                 case '$':
13159                 case '.':
13160                 case '[':
13161                 case '(':
13162                 case ')':
13163                 case '|':
13164                     goto loopdone;
13165                 case '\\':
13166                     /* Literal Escapes Switch
13167
13168                        This switch is meant to handle escape sequences that
13169                        resolve to a literal character.
13170
13171                        Every escape sequence that represents something
13172                        else, like an assertion or a char class, is handled
13173                        in the switch marked 'Special Escapes' above in this
13174                        routine, but also has an entry here as anything that
13175                        isn't explicitly mentioned here will be treated as
13176                        an unescaped equivalent literal.
13177                     */
13178
13179                     switch ((U8)*++p) {
13180                     /* These are all the special escapes. */
13181                     case 'A':             /* Start assertion */
13182                     case 'b': case 'B':   /* Word-boundary assertion*/
13183                     case 'C':             /* Single char !DANGEROUS! */
13184                     case 'd': case 'D':   /* digit class */
13185                     case 'g': case 'G':   /* generic-backref, pos assertion */
13186                     case 'h': case 'H':   /* HORIZWS */
13187                     case 'k': case 'K':   /* named backref, keep marker */
13188                     case 'p': case 'P':   /* Unicode property */
13189                               case 'R':   /* LNBREAK */
13190                     case 's': case 'S':   /* space class */
13191                     case 'v': case 'V':   /* VERTWS */
13192                     case 'w': case 'W':   /* word class */
13193                     case 'X':             /* eXtended Unicode "combining
13194                                              character sequence" */
13195                     case 'z': case 'Z':   /* End of line/string assertion */
13196                         --p;
13197                         goto loopdone;
13198
13199                     /* Anything after here is an escape that resolves to a
13200                        literal. (Except digits, which may or may not)
13201                      */
13202                     case 'n':
13203                         ender = '\n';
13204                         p++;
13205                         break;
13206                     case 'N': /* Handle a single-code point named character. */
13207                         RExC_parse = p + 1;
13208                         if (! grok_bslash_N(pRExC_state,
13209                                             NULL,   /* Fail if evaluates to
13210                                                        anything other than a
13211                                                        single code point */
13212                                             &ender, /* The returned single code
13213                                                        point */
13214                                             NULL,   /* Don't need a count of
13215                                                        how many code points */
13216                                             flagp,
13217                                             RExC_strict,
13218                                             depth)
13219                         ) {
13220                             if (*flagp & NEED_UTF8)
13221                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13222                             if (*flagp & RESTART_PASS1)
13223                                 return NULL;
13224
13225                             /* Here, it wasn't a single code point.  Go close
13226                              * up this EXACTish node.  The switch() prior to
13227                              * this switch handles the other cases */
13228                             RExC_parse = p = oldp;
13229                             goto loopdone;
13230                         }
13231                         p = RExC_parse;
13232                         if (ender > 0xff) {
13233                             REQUIRE_UTF8(flagp);
13234                         }
13235                         break;
13236                     case 'r':
13237                         ender = '\r';
13238                         p++;
13239                         break;
13240                     case 't':
13241                         ender = '\t';
13242                         p++;
13243                         break;
13244                     case 'f':
13245                         ender = '\f';
13246                         p++;
13247                         break;
13248                     case 'e':
13249                         ender = ESC_NATIVE;
13250                         p++;
13251                         break;
13252                     case 'a':
13253                         ender = '\a';
13254                         p++;
13255                         break;
13256                     case 'o':
13257                         {
13258                             UV result;
13259                             const char* error_msg;
13260
13261                             bool valid = grok_bslash_o(&p,
13262                                                        &result,
13263                                                        &error_msg,
13264                                                        PASS2, /* out warnings */
13265                                                        (bool) RExC_strict,
13266                                                        TRUE, /* Output warnings
13267                                                                 for non-
13268                                                                 portables */
13269                                                        UTF);
13270                             if (! valid) {
13271                                 RExC_parse = p; /* going to die anyway; point
13272                                                    to exact spot of failure */
13273                                 vFAIL(error_msg);
13274                             }
13275                             ender = result;
13276                             if (ender > 0xff) {
13277                                 REQUIRE_UTF8(flagp);
13278                             }
13279                             break;
13280                         }
13281                     case 'x':
13282                         {
13283                             UV result = UV_MAX; /* initialize to erroneous
13284                                                    value */
13285                             const char* error_msg;
13286
13287                             bool valid = grok_bslash_x(&p,
13288                                                        &result,
13289                                                        &error_msg,
13290                                                        PASS2, /* out warnings */
13291                                                        (bool) RExC_strict,
13292                                                        TRUE, /* Silence warnings
13293                                                                 for non-
13294                                                                 portables */
13295                                                        UTF);
13296                             if (! valid) {
13297                                 RExC_parse = p; /* going to die anyway; point
13298                                                    to exact spot of failure */
13299                                 vFAIL(error_msg);
13300                             }
13301                             ender = result;
13302
13303                             if (ender < 0x100) {
13304 #ifdef EBCDIC
13305                                 if (RExC_recode_x_to_native) {
13306                                     ender = LATIN1_TO_NATIVE(ender);
13307                                 }
13308 #endif
13309                             }
13310                             else {
13311                                 REQUIRE_UTF8(flagp);
13312                             }
13313                             break;
13314                         }
13315                     case 'c':
13316                         p++;
13317                         ender = grok_bslash_c(*p++, PASS2);
13318                         break;
13319                     case '8': case '9': /* must be a backreference */
13320                         --p;
13321                         /* we have an escape like \8 which cannot be an octal escape
13322                          * so we exit the loop, and let the outer loop handle this
13323                          * escape which may or may not be a legitimate backref. */
13324                         goto loopdone;
13325                     case '1': case '2': case '3':case '4':
13326                     case '5': case '6': case '7':
13327                         /* When we parse backslash escapes there is ambiguity
13328                          * between backreferences and octal escapes. Any escape
13329                          * from \1 - \9 is a backreference, any multi-digit
13330                          * escape which does not start with 0 and which when
13331                          * evaluated as decimal could refer to an already
13332                          * parsed capture buffer is a back reference. Anything
13333                          * else is octal.
13334                          *
13335                          * Note this implies that \118 could be interpreted as
13336                          * 118 OR as "\11" . "8" depending on whether there
13337                          * were 118 capture buffers defined already in the
13338                          * pattern.  */
13339
13340                         /* NOTE, RExC_npar is 1 more than the actual number of
13341                          * parens we have seen so far, hence the < RExC_npar below. */
13342
13343                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13344                         {  /* Not to be treated as an octal constant, go
13345                                    find backref */
13346                             --p;
13347                             goto loopdone;
13348                         }
13349                         /* FALLTHROUGH */
13350                     case '0':
13351                         {
13352                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13353                             STRLEN numlen = 3;
13354                             ender = grok_oct(p, &numlen, &flags, NULL);
13355                             if (ender > 0xff) {
13356                                 REQUIRE_UTF8(flagp);
13357                             }
13358                             p += numlen;
13359                             if (PASS2   /* like \08, \178 */
13360                                 && numlen < 3
13361                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13362                             {
13363                                 reg_warn_non_literal_string(
13364                                          p + 1,
13365                                          form_short_octal_warning(p, numlen));
13366                             }
13367                         }
13368                         break;
13369                     case '\0':
13370                         if (p >= RExC_end)
13371                             FAIL("Trailing \\");
13372                         /* FALLTHROUGH */
13373                     default:
13374                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13375                             /* Include any left brace following the alpha to emphasize
13376                              * that it could be part of an escape at some point
13377                              * in the future */
13378                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13379                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13380                         }
13381                         goto normal_default;
13382                     } /* End of switch on '\' */
13383                     break;
13384                 case '{':
13385                     /* Currently we don't care if the lbrace is at the start
13386                      * of a construct.  This catches it in the middle of a
13387                      * literal string, or when it's the first thing after
13388                      * something like "\b" */
13389                     if (len || (p > RExC_start && isALPHA_A(*(p -1)))) {
13390                         RExC_parse = p + 1;
13391                         vFAIL("Unescaped left brace in regex is illegal here");
13392                     }
13393                     goto normal_default;
13394                 case '}':
13395                 case ']':
13396                     if (PASS2 && p > RExC_parse && RExC_strict) {
13397                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
13398                     }
13399                     /*FALLTHROUGH*/
13400                 default:    /* A literal character */
13401                   normal_default:
13402                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13403                         STRLEN numlen;
13404                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13405                                                &numlen, UTF8_ALLOW_DEFAULT);
13406                         p += numlen;
13407                     }
13408                     else
13409                         ender = (U8) *p++;
13410                     break;
13411                 } /* End of switch on the literal */
13412
13413                 /* Here, have looked at the literal character and <ender>
13414                  * contains its ordinal, <p> points to the character after it.
13415                  * We need to check if the next non-ignored thing is a
13416                  * quantifier.  Move <p> to after anything that should be
13417                  * ignored, which, as a side effect, positions <p> for the next
13418                  * loop iteration */
13419                 skip_to_be_ignored_text(pRExC_state, &p,
13420                                         FALSE /* Don't force to /x */ );
13421
13422                 /* If the next thing is a quantifier, it applies to this
13423                  * character only, which means that this character has to be in
13424                  * its own node and can't just be appended to the string in an
13425                  * existing node, so if there are already other characters in
13426                  * the node, close the node with just them, and set up to do
13427                  * this character again next time through, when it will be the
13428                  * only thing in its new node */
13429
13430                 if ((next_is_quantifier = (   LIKELY(p < RExC_end)
13431                                            && UNLIKELY(ISMULT2(p))))
13432                     && LIKELY(len))
13433                 {
13434                     p = oldp;
13435                     goto loopdone;
13436                 }
13437
13438                 /* Ready to add 'ender' to the node */
13439
13440                 if (! FOLD) {  /* The simple case, just append the literal */
13441
13442                     /* In the sizing pass, we need only the size of the
13443                      * character we are appending, hence we can delay getting
13444                      * its representation until PASS2. */
13445                     if (SIZE_ONLY) {
13446                         if (UTF) {
13447                             const STRLEN unilen = UVCHR_SKIP(ender);
13448                             s += unilen;
13449
13450                             /* We have to subtract 1 just below (and again in
13451                              * the corresponding PASS2 code) because the loop
13452                              * increments <len> each time, as all but this path
13453                              * (and one other) through it add a single byte to
13454                              * the EXACTish node.  But these paths would change
13455                              * len to be the correct final value, so cancel out
13456                              * the increment that follows */
13457                             len += unilen - 1;
13458                         }
13459                         else {
13460                             s++;
13461                         }
13462                     } else { /* PASS2 */
13463                       not_fold_common:
13464                         if (UTF) {
13465                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13466                             len += (char *) new_s - s - 1;
13467                             s = (char *) new_s;
13468                         }
13469                         else {
13470                             *(s++) = (char) ender;
13471                         }
13472                     }
13473                 }
13474                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13475
13476                     /* Here are folding under /l, and the code point is
13477                      * problematic.  First, we know we can't simplify things */
13478                     maybe_exact = FALSE;
13479                     maybe_exactfu = FALSE;
13480
13481                     /* A problematic code point in this context means that its
13482                      * fold isn't known until runtime, so we can't fold it now.
13483                      * (The non-problematic code points are the above-Latin1
13484                      * ones that fold to also all above-Latin1.  Their folds
13485                      * don't vary no matter what the locale is.) But here we
13486                      * have characters whose fold depends on the locale.
13487                      * Unlike the non-folding case above, we have to keep track
13488                      * of these in the sizing pass, so that we can make sure we
13489                      * don't split too-long nodes in the middle of a potential
13490                      * multi-char fold.  And unlike the regular fold case
13491                      * handled in the else clauses below, we don't actually
13492                      * fold and don't have special cases to consider.  What we
13493                      * do for both passes is the PASS2 code for non-folding */
13494                     goto not_fold_common;
13495                 }
13496                 else /* A regular FOLD code point */
13497                     if (! (   UTF
13498 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13499    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13500                                       || UNICODE_DOT_DOT_VERSION > 0)
13501                             /* See comments for join_exact() as to why we fold
13502                              * this non-UTF at compile time */
13503                             || (   node_type == EXACTFU
13504                                 && ender == LATIN_SMALL_LETTER_SHARP_S)
13505 #endif
13506                 )) {
13507                     /* Here, are folding and are not UTF-8 encoded; therefore
13508                      * the character must be in the range 0-255, and is not /l
13509                      * (Not /l because we already handled these under /l in
13510                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13511                     if (IS_IN_SOME_FOLD_L1(ender)) {
13512                         maybe_exact = FALSE;
13513
13514                         /* See if the character's fold differs between /d and
13515                          * /u.  This includes the multi-char fold SHARP S to
13516                          * 'ss' */
13517                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13518                             RExC_seen_unfolded_sharp_s = 1;
13519                             maybe_exactfu = FALSE;
13520                         }
13521                         else if (maybe_exactfu
13522                             && (PL_fold[ender] != PL_fold_latin1[ender]
13523 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13524    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13525                                       || UNICODE_DOT_DOT_VERSION > 0)
13526                                 || (   len > 0
13527                                     && isALPHA_FOLD_EQ(ender, 's')
13528                                     && isALPHA_FOLD_EQ(*(s-1), 's'))
13529 #endif
13530                         )) {
13531                             maybe_exactfu = FALSE;
13532                         }
13533                     }
13534
13535                     /* Even when folding, we store just the input character, as
13536                      * we have an array that finds its fold quickly */
13537                     *(s++) = (char) ender;
13538                 }
13539                 else {  /* FOLD, and UTF (or sharp s) */
13540                     /* Unlike the non-fold case, we do actually have to
13541                      * calculate the results here in pass 1.  This is for two
13542                      * reasons, the folded length may be longer than the
13543                      * unfolded, and we have to calculate how many EXACTish
13544                      * nodes it will take; and we may run out of room in a node
13545                      * in the middle of a potential multi-char fold, and have
13546                      * to back off accordingly.  */
13547
13548                     UV folded;
13549                     if (isASCII_uni(ender)) {
13550                         folded = toFOLD(ender);
13551                         *(s)++ = (U8) folded;
13552                     }
13553                     else {
13554                         STRLEN foldlen;
13555
13556                         folded = _to_uni_fold_flags(
13557                                      ender,
13558                                      (U8 *) s,
13559                                      &foldlen,
13560                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
13561                                                         ? FOLD_FLAGS_NOMIX_ASCII
13562                                                         : 0));
13563                         s += foldlen;
13564
13565                         /* The loop increments <len> each time, as all but this
13566                          * path (and one other) through it add a single byte to
13567                          * the EXACTish node.  But this one has changed len to
13568                          * be the correct final value, so subtract one to
13569                          * cancel out the increment that follows */
13570                         len += foldlen - 1;
13571                     }
13572                     /* If this node only contains non-folding code points so
13573                      * far, see if this new one is also non-folding */
13574                     if (maybe_exact) {
13575                         if (folded != ender) {
13576                             maybe_exact = FALSE;
13577                         }
13578                         else {
13579                             /* Here the fold is the original; we have to check
13580                              * further to see if anything folds to it */
13581                             if (_invlist_contains_cp(PL_utf8_foldable,
13582                                                         ender))
13583                             {
13584                                 maybe_exact = FALSE;
13585                             }
13586                         }
13587                     }
13588                     ender = folded;
13589                 }
13590
13591                 if (next_is_quantifier) {
13592
13593                     /* Here, the next input is a quantifier, and to get here,
13594                      * the current character is the only one in the node.
13595                      * Also, here <len> doesn't include the final byte for this
13596                      * character */
13597                     len++;
13598                     goto loopdone;
13599                 }
13600
13601             } /* End of loop through literal characters */
13602
13603             /* Here we have either exhausted the input or ran out of room in
13604              * the node.  (If we encountered a character that can't be in the
13605              * node, transfer is made directly to <loopdone>, and so we
13606              * wouldn't have fallen off the end of the loop.)  In the latter
13607              * case, we artificially have to split the node into two, because
13608              * we just don't have enough space to hold everything.  This
13609              * creates a problem if the final character participates in a
13610              * multi-character fold in the non-final position, as a match that
13611              * should have occurred won't, due to the way nodes are matched,
13612              * and our artificial boundary.  So back off until we find a non-
13613              * problematic character -- one that isn't at the beginning or
13614              * middle of such a fold.  (Either it doesn't participate in any
13615              * folds, or appears only in the final position of all the folds it
13616              * does participate in.)  A better solution with far fewer false
13617              * positives, and that would fill the nodes more completely, would
13618              * be to actually have available all the multi-character folds to
13619              * test against, and to back-off only far enough to be sure that
13620              * this node isn't ending with a partial one.  <upper_parse> is set
13621              * further below (if we need to reparse the node) to include just
13622              * up through that final non-problematic character that this code
13623              * identifies, so when it is set to less than the full node, we can
13624              * skip the rest of this */
13625             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
13626
13627                 const STRLEN full_len = len;
13628
13629                 assert(len >= MAX_NODE_STRING_SIZE);
13630
13631                 /* Here, <s> points to the final byte of the final character.
13632                  * Look backwards through the string until find a non-
13633                  * problematic character */
13634
13635                 if (! UTF) {
13636
13637                     /* This has no multi-char folds to non-UTF characters */
13638                     if (ASCII_FOLD_RESTRICTED) {
13639                         goto loopdone;
13640                     }
13641
13642                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
13643                     len = s - s0 + 1;
13644                 }
13645                 else {
13646                     if (!  PL_NonL1NonFinalFold) {
13647                         PL_NonL1NonFinalFold = _new_invlist_C_array(
13648                                         NonL1_Perl_Non_Final_Folds_invlist);
13649                     }
13650
13651                     /* Point to the first byte of the final character */
13652                     s = (char *) utf8_hop((U8 *) s, -1);
13653
13654                     while (s >= s0) {   /* Search backwards until find
13655                                            non-problematic char */
13656                         if (UTF8_IS_INVARIANT(*s)) {
13657
13658                             /* There are no ascii characters that participate
13659                              * in multi-char folds under /aa.  In EBCDIC, the
13660                              * non-ascii invariants are all control characters,
13661                              * so don't ever participate in any folds. */
13662                             if (ASCII_FOLD_RESTRICTED
13663                                 || ! IS_NON_FINAL_FOLD(*s))
13664                             {
13665                                 break;
13666                             }
13667                         }
13668                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
13669                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
13670                                                                   *s, *(s+1))))
13671                             {
13672                                 break;
13673                             }
13674                         }
13675                         else if (! _invlist_contains_cp(
13676                                         PL_NonL1NonFinalFold,
13677                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
13678                         {
13679                             break;
13680                         }
13681
13682                         /* Here, the current character is problematic in that
13683                          * it does occur in the non-final position of some
13684                          * fold, so try the character before it, but have to
13685                          * special case the very first byte in the string, so
13686                          * we don't read outside the string */
13687                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
13688                     } /* End of loop backwards through the string */
13689
13690                     /* If there were only problematic characters in the string,
13691                      * <s> will point to before s0, in which case the length
13692                      * should be 0, otherwise include the length of the
13693                      * non-problematic character just found */
13694                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
13695                 }
13696
13697                 /* Here, have found the final character, if any, that is
13698                  * non-problematic as far as ending the node without splitting
13699                  * it across a potential multi-char fold.  <len> contains the
13700                  * number of bytes in the node up-to and including that
13701                  * character, or is 0 if there is no such character, meaning
13702                  * the whole node contains only problematic characters.  In
13703                  * this case, give up and just take the node as-is.  We can't
13704                  * do any better */
13705                 if (len == 0) {
13706                     len = full_len;
13707
13708                     /* If the node ends in an 's' we make sure it stays EXACTF,
13709                      * as if it turns into an EXACTFU, it could later get
13710                      * joined with another 's' that would then wrongly match
13711                      * the sharp s */
13712                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
13713                     {
13714                         maybe_exactfu = FALSE;
13715                     }
13716                 } else {
13717
13718                     /* Here, the node does contain some characters that aren't
13719                      * problematic.  If one such is the final character in the
13720                      * node, we are done */
13721                     if (len == full_len) {
13722                         goto loopdone;
13723                     }
13724                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
13725
13726                         /* If the final character is problematic, but the
13727                          * penultimate is not, back-off that last character to
13728                          * later start a new node with it */
13729                         p = oldp;
13730                         goto loopdone;
13731                     }
13732
13733                     /* Here, the final non-problematic character is earlier
13734                      * in the input than the penultimate character.  What we do
13735                      * is reparse from the beginning, going up only as far as
13736                      * this final ok one, thus guaranteeing that the node ends
13737                      * in an acceptable character.  The reason we reparse is
13738                      * that we know how far in the character is, but we don't
13739                      * know how to correlate its position with the input parse.
13740                      * An alternate implementation would be to build that
13741                      * correlation as we go along during the original parse,
13742                      * but that would entail extra work for every node, whereas
13743                      * this code gets executed only when the string is too
13744                      * large for the node, and the final two characters are
13745                      * problematic, an infrequent occurrence.  Yet another
13746                      * possible strategy would be to save the tail of the
13747                      * string, and the next time regatom is called, initialize
13748                      * with that.  The problem with this is that unless you
13749                      * back off one more character, you won't be guaranteed
13750                      * regatom will get called again, unless regbranch,
13751                      * regpiece ... are also changed.  If you do back off that
13752                      * extra character, so that there is input guaranteed to
13753                      * force calling regatom, you can't handle the case where
13754                      * just the first character in the node is acceptable.  I
13755                      * (khw) decided to try this method which doesn't have that
13756                      * pitfall; if performance issues are found, we can do a
13757                      * combination of the current approach plus that one */
13758                     upper_parse = len;
13759                     len = 0;
13760                     s = s0;
13761                     goto reparse;
13762                 }
13763             }   /* End of verifying node ends with an appropriate char */
13764
13765           loopdone:   /* Jumped to when encounters something that shouldn't be
13766                          in the node */
13767
13768             /* I (khw) don't know if you can get here with zero length, but the
13769              * old code handled this situation by creating a zero-length EXACT
13770              * node.  Might as well be NOTHING instead */
13771             if (len == 0) {
13772                 OP(ret) = NOTHING;
13773             }
13774             else {
13775                 if (FOLD) {
13776                     /* If 'maybe_exact' is still set here, means there are no
13777                      * code points in the node that participate in folds;
13778                      * similarly for 'maybe_exactfu' and code points that match
13779                      * differently depending on UTF8ness of the target string
13780                      * (for /u), or depending on locale for /l */
13781                     if (maybe_exact) {
13782                         OP(ret) = (LOC)
13783                                   ? EXACTL
13784                                   : EXACT;
13785                     }
13786                     else if (maybe_exactfu) {
13787                         OP(ret) = (LOC)
13788                                   ? EXACTFLU8
13789                                   : EXACTFU;
13790                     }
13791                 }
13792                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
13793                                            FALSE /* Don't look to see if could
13794                                                     be turned into an EXACT
13795                                                     node, as we have already
13796                                                     computed that */
13797                                           );
13798             }
13799
13800             RExC_parse = p - 1;
13801             Set_Node_Cur_Length(ret, parse_start);
13802             RExC_parse = p;
13803             {
13804                 /* len is STRLEN which is unsigned, need to copy to signed */
13805                 IV iv = len;
13806                 if (iv < 0)
13807                     vFAIL("Internal disaster");
13808             }
13809
13810         } /* End of label 'defchar:' */
13811         break;
13812     } /* End of giant switch on input character */
13813
13814     /* Position parse to next real character */
13815     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13816                                             FALSE /* Don't force to /x */ );
13817     if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
13818         ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here (and will be fatal in Perl 5.30), passed through");
13819     }
13820
13821     return(ret);
13822 }
13823
13824
13825 STATIC void
13826 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
13827 {
13828     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13829      * sets up the bitmap and any flags, removing those code points from the
13830      * inversion list, setting it to NULL should it become completely empty */
13831
13832     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13833     assert(PL_regkind[OP(node)] == ANYOF);
13834
13835     ANYOF_BITMAP_ZERO(node);
13836     if (*invlist_ptr) {
13837
13838         /* This gets set if we actually need to modify things */
13839         bool change_invlist = FALSE;
13840
13841         UV start, end;
13842
13843         /* Start looking through *invlist_ptr */
13844         invlist_iterinit(*invlist_ptr);
13845         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13846             UV high;
13847             int i;
13848
13849             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13850                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13851             }
13852
13853             /* Quit if are above what we should change */
13854             if (start >= NUM_ANYOF_CODE_POINTS) {
13855                 break;
13856             }
13857
13858             change_invlist = TRUE;
13859
13860             /* Set all the bits in the range, up to the max that we are doing */
13861             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13862                    ? end
13863                    : NUM_ANYOF_CODE_POINTS - 1;
13864             for (i = start; i <= (int) high; i++) {
13865                 if (! ANYOF_BITMAP_TEST(node, i)) {
13866                     ANYOF_BITMAP_SET(node, i);
13867                 }
13868             }
13869         }
13870         invlist_iterfinish(*invlist_ptr);
13871
13872         /* Done with loop; remove any code points that are in the bitmap from
13873          * *invlist_ptr; similarly for code points above the bitmap if we have
13874          * a flag to match all of them anyways */
13875         if (change_invlist) {
13876             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13877         }
13878         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13879             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13880         }
13881
13882         /* If have completely emptied it, remove it completely */
13883         if (_invlist_len(*invlist_ptr) == 0) {
13884             SvREFCNT_dec_NN(*invlist_ptr);
13885             *invlist_ptr = NULL;
13886         }
13887     }
13888 }
13889
13890 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
13891    Character classes ([:foo:]) can also be negated ([:^foo:]).
13892    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
13893    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
13894    but trigger failures because they are currently unimplemented. */
13895
13896 #define POSIXCC_DONE(c)   ((c) == ':')
13897 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
13898 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
13899 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
13900
13901 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
13902 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
13903 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
13904
13905 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
13906
13907 /* 'posix_warnings' and 'warn_text' are names of variables in the following
13908  * routine. q.v. */
13909 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
13910         if (posix_warnings) {                                               \
13911             if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
13912             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                          \
13913                                              WARNING_PREFIX                 \
13914                                              text                           \
13915                                              REPORT_LOCATION,               \
13916                                              REPORT_LOCATION_ARGS(p)));     \
13917         }                                                                   \
13918     } STMT_END
13919
13920 STATIC int
13921 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
13922
13923     const char * const s,      /* Where the putative posix class begins.
13924                                   Normally, this is one past the '['.  This
13925                                   parameter exists so it can be somewhere
13926                                   besides RExC_parse. */
13927     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
13928                                   NULL */
13929     AV ** posix_warnings,      /* Where to place any generated warnings, or
13930                                   NULL */
13931     const bool check_only      /* Don't die if error */
13932 )
13933 {
13934     /* This parses what the caller thinks may be one of the three POSIX
13935      * constructs:
13936      *  1) a character class, like [:blank:]
13937      *  2) a collating symbol, like [. .]
13938      *  3) an equivalence class, like [= =]
13939      * In the latter two cases, it croaks if it finds a syntactically legal
13940      * one, as these are not handled by Perl.
13941      *
13942      * The main purpose is to look for a POSIX character class.  It returns:
13943      *  a) the class number
13944      *      if it is a completely syntactically and semantically legal class.
13945      *      'updated_parse_ptr', if not NULL, is set to point to just after the
13946      *      closing ']' of the class
13947      *  b) OOB_NAMEDCLASS
13948      *      if it appears that one of the three POSIX constructs was meant, but
13949      *      its specification was somehow defective.  'updated_parse_ptr', if
13950      *      not NULL, is set to point to the character just after the end
13951      *      character of the class.  See below for handling of warnings.
13952      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
13953      *      if it  doesn't appear that a POSIX construct was intended.
13954      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
13955      *      raised.
13956      *
13957      * In b) there may be errors or warnings generated.  If 'check_only' is
13958      * TRUE, then any errors are discarded.  Warnings are returned to the
13959      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
13960      * instead it is NULL, warnings are suppressed.  This is done in all
13961      * passes.  The reason for this is that the rest of the parsing is heavily
13962      * dependent on whether this routine found a valid posix class or not.  If
13963      * it did, the closing ']' is absorbed as part of the class.  If no class,
13964      * or an invalid one is found, any ']' will be considered the terminator of
13965      * the outer bracketed character class, leading to very different results.
13966      * In particular, a '(?[ ])' construct will likely have a syntax error if
13967      * the class is parsed other than intended, and this will happen in pass1,
13968      * before the warnings would normally be output.  This mechanism allows the
13969      * caller to output those warnings in pass1 just before dieing, giving a
13970      * much better clue as to what is wrong.
13971      *
13972      * The reason for this function, and its complexity is that a bracketed
13973      * character class can contain just about anything.  But it's easy to
13974      * mistype the very specific posix class syntax but yielding a valid
13975      * regular bracketed class, so it silently gets compiled into something
13976      * quite unintended.
13977      *
13978      * The solution adopted here maintains backward compatibility except that
13979      * it adds a warning if it looks like a posix class was intended but
13980      * improperly specified.  The warning is not raised unless what is input
13981      * very closely resembles one of the 14 legal posix classes.  To do this,
13982      * it uses fuzzy parsing.  It calculates how many single-character edits it
13983      * would take to transform what was input into a legal posix class.  Only
13984      * if that number is quite small does it think that the intention was a
13985      * posix class.  Obviously these are heuristics, and there will be cases
13986      * where it errs on one side or another, and they can be tweaked as
13987      * experience informs.
13988      *
13989      * The syntax for a legal posix class is:
13990      *
13991      * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
13992      *
13993      * What this routine considers syntactically to be an intended posix class
13994      * is this (the comments indicate some restrictions that the pattern
13995      * doesn't show):
13996      *
13997      *  qr/(?x: \[?                         # The left bracket, possibly
13998      *                                      # omitted
13999      *          \h*                         # possibly followed by blanks
14000      *          (?: \^ \h* )?               # possibly a misplaced caret
14001      *          [:;]?                       # The opening class character,
14002      *                                      # possibly omitted.  A typo
14003      *                                      # semi-colon can also be used.
14004      *          \h*
14005      *          \^?                         # possibly a correctly placed
14006      *                                      # caret, but not if there was also
14007      *                                      # a misplaced one
14008      *          \h*
14009      *          .{3,15}                     # The class name.  If there are
14010      *                                      # deviations from the legal syntax,
14011      *                                      # its edit distance must be close
14012      *                                      # to a real class name in order
14013      *                                      # for it to be considered to be
14014      *                                      # an intended posix class.
14015      *          \h*
14016      *          [:punct:]?                  # The closing class character,
14017      *                                      # possibly omitted.  If not a colon
14018      *                                      # nor semi colon, the class name
14019      *                                      # must be even closer to a valid
14020      *                                      # one
14021      *          \h*
14022      *          \]?                         # The right bracket, possibly
14023      *                                      # omitted.
14024      *     )/
14025      *
14026      * In the above, \h must be ASCII-only.
14027      *
14028      * These are heuristics, and can be tweaked as field experience dictates.
14029      * There will be cases when someone didn't intend to specify a posix class
14030      * that this warns as being so.  The goal is to minimize these, while
14031      * maximizing the catching of things intended to be a posix class that
14032      * aren't parsed as such.
14033      */
14034
14035     const char* p             = s;
14036     const char * const e      = RExC_end;
14037     unsigned complement       = 0;      /* If to complement the class */
14038     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
14039     bool has_opening_bracket  = FALSE;
14040     bool has_opening_colon    = FALSE;
14041     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
14042                                                    valid class */
14043     const char * possible_end = NULL;   /* used for a 2nd parse pass */
14044     const char* name_start;             /* ptr to class name first char */
14045
14046     /* If the number of single-character typos the input name is away from a
14047      * legal name is no more than this number, it is considered to have meant
14048      * the legal name */
14049     int max_distance          = 2;
14050
14051     /* to store the name.  The size determines the maximum length before we
14052      * decide that no posix class was intended.  Should be at least
14053      * sizeof("alphanumeric") */
14054     UV input_text[15];
14055
14056     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
14057
14058     if (posix_warnings && RExC_warn_text)
14059         av_clear(RExC_warn_text);
14060
14061     if (p >= e) {
14062         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14063     }
14064
14065     if (*(p - 1) != '[') {
14066         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
14067         found_problem = TRUE;
14068     }
14069     else {
14070         has_opening_bracket = TRUE;
14071     }
14072
14073     /* They could be confused and think you can put spaces between the
14074      * components */
14075     if (isBLANK(*p)) {
14076         found_problem = TRUE;
14077
14078         do {
14079             p++;
14080         } while (p < e && isBLANK(*p));
14081
14082         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14083     }
14084
14085     /* For [. .] and [= =].  These are quite different internally from [: :],
14086      * so they are handled separately.  */
14087     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
14088                                             and 1 for at least one char in it
14089                                           */
14090     {
14091         const char open_char  = *p;
14092         const char * temp_ptr = p + 1;
14093
14094         /* These two constructs are not handled by perl, and if we find a
14095          * syntactically valid one, we croak.  khw, who wrote this code, finds
14096          * this explanation of them very unclear:
14097          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
14098          * And searching the rest of the internet wasn't very helpful either.
14099          * It looks like just about any byte can be in these constructs,
14100          * depending on the locale.  But unless the pattern is being compiled
14101          * under /l, which is very rare, Perl runs under the C or POSIX locale.
14102          * In that case, it looks like [= =] isn't allowed at all, and that
14103          * [. .] could be any single code point, but for longer strings the
14104          * constituent characters would have to be the ASCII alphabetics plus
14105          * the minus-hyphen.  Any sensible locale definition would limit itself
14106          * to these.  And any portable one definitely should.  Trying to parse
14107          * the general case is a nightmare (see [perl #127604]).  So, this code
14108          * looks only for interiors of these constructs that match:
14109          *      qr/.|[-\w]{2,}/
14110          * Using \w relaxes the apparent rules a little, without adding much
14111          * danger of mistaking something else for one of these constructs.
14112          *
14113          * [. .] in some implementations described on the internet is usable to
14114          * escape a character that otherwise is special in bracketed character
14115          * classes.  For example [.].] means a literal right bracket instead of
14116          * the ending of the class
14117          *
14118          * [= =] can legitimately contain a [. .] construct, but we don't
14119          * handle this case, as that [. .] construct will later get parsed
14120          * itself and croak then.  And [= =] is checked for even when not under
14121          * /l, as Perl has long done so.
14122          *
14123          * The code below relies on there being a trailing NUL, so it doesn't
14124          * have to keep checking if the parse ptr < e.
14125          */
14126         if (temp_ptr[1] == open_char) {
14127             temp_ptr++;
14128         }
14129         else while (    temp_ptr < e
14130                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
14131         {
14132             temp_ptr++;
14133         }
14134
14135         if (*temp_ptr == open_char) {
14136             temp_ptr++;
14137             if (*temp_ptr == ']') {
14138                 temp_ptr++;
14139                 if (! found_problem && ! check_only) {
14140                     RExC_parse = (char *) temp_ptr;
14141                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
14142                             "extensions", open_char, open_char);
14143                 }
14144
14145                 /* Here, the syntax wasn't completely valid, or else the call
14146                  * is to check-only */
14147                 if (updated_parse_ptr) {
14148                     *updated_parse_ptr = (char *) temp_ptr;
14149                 }
14150
14151                 return OOB_NAMEDCLASS;
14152             }
14153         }
14154
14155         /* If we find something that started out to look like one of these
14156          * constructs, but isn't, we continue below so that it can be checked
14157          * for being a class name with a typo of '.' or '=' instead of a colon.
14158          * */
14159     }
14160
14161     /* Here, we think there is a possibility that a [: :] class was meant, and
14162      * we have the first real character.  It could be they think the '^' comes
14163      * first */
14164     if (*p == '^') {
14165         found_problem = TRUE;
14166         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
14167         complement = 1;
14168         p++;
14169
14170         if (isBLANK(*p)) {
14171             found_problem = TRUE;
14172
14173             do {
14174                 p++;
14175             } while (p < e && isBLANK(*p));
14176
14177             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14178         }
14179     }
14180
14181     /* But the first character should be a colon, which they could have easily
14182      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
14183      * distinguish from a colon, so treat that as a colon).  */
14184     if (*p == ':') {
14185         p++;
14186         has_opening_colon = TRUE;
14187     }
14188     else if (*p == ';') {
14189         found_problem = TRUE;
14190         p++;
14191         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14192         has_opening_colon = TRUE;
14193     }
14194     else {
14195         found_problem = TRUE;
14196         ADD_POSIX_WARNING(p, "there must be a starting ':'");
14197
14198         /* Consider an initial punctuation (not one of the recognized ones) to
14199          * be a left terminator */
14200         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
14201             p++;
14202         }
14203     }
14204
14205     /* They may think that you can put spaces between the components */
14206     if (isBLANK(*p)) {
14207         found_problem = TRUE;
14208
14209         do {
14210             p++;
14211         } while (p < e && isBLANK(*p));
14212
14213         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14214     }
14215
14216     if (*p == '^') {
14217
14218         /* We consider something like [^:^alnum:]] to not have been intended to
14219          * be a posix class, but XXX maybe we should */
14220         if (complement) {
14221             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14222         }
14223
14224         complement = 1;
14225         p++;
14226     }
14227
14228     /* Again, they may think that you can put spaces between the components */
14229     if (isBLANK(*p)) {
14230         found_problem = TRUE;
14231
14232         do {
14233             p++;
14234         } while (p < e && isBLANK(*p));
14235
14236         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14237     }
14238
14239     if (*p == ']') {
14240
14241         /* XXX This ']' may be a typo, and something else was meant.  But
14242          * treating it as such creates enough complications, that that
14243          * possibility isn't currently considered here.  So we assume that the
14244          * ']' is what is intended, and if we've already found an initial '[',
14245          * this leaves this construct looking like [:] or [:^], which almost
14246          * certainly weren't intended to be posix classes */
14247         if (has_opening_bracket) {
14248             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14249         }
14250
14251         /* But this function can be called when we parse the colon for
14252          * something like qr/[alpha:]]/, so we back up to look for the
14253          * beginning */
14254         p--;
14255
14256         if (*p == ';') {
14257             found_problem = TRUE;
14258             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14259         }
14260         else if (*p != ':') {
14261
14262             /* XXX We are currently very restrictive here, so this code doesn't
14263              * consider the possibility that, say, /[alpha.]]/ was intended to
14264              * be a posix class. */
14265             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14266         }
14267
14268         /* Here we have something like 'foo:]'.  There was no initial colon,
14269          * and we back up over 'foo.  XXX Unlike the going forward case, we
14270          * don't handle typos of non-word chars in the middle */
14271         has_opening_colon = FALSE;
14272         p--;
14273
14274         while (p > RExC_start && isWORDCHAR(*p)) {
14275             p--;
14276         }
14277         p++;
14278
14279         /* Here, we have positioned ourselves to where we think the first
14280          * character in the potential class is */
14281     }
14282
14283     /* Now the interior really starts.  There are certain key characters that
14284      * can end the interior, or these could just be typos.  To catch both
14285      * cases, we may have to do two passes.  In the first pass, we keep on
14286      * going unless we come to a sequence that matches
14287      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14288      * This means it takes a sequence to end the pass, so two typos in a row if
14289      * that wasn't what was intended.  If the class is perfectly formed, just
14290      * this one pass is needed.  We also stop if there are too many characters
14291      * being accumulated, but this number is deliberately set higher than any
14292      * real class.  It is set high enough so that someone who thinks that
14293      * 'alphanumeric' is a correct name would get warned that it wasn't.
14294      * While doing the pass, we keep track of where the key characters were in
14295      * it.  If we don't find an end to the class, and one of the key characters
14296      * was found, we redo the pass, but stop when we get to that character.
14297      * Thus the key character was considered a typo in the first pass, but a
14298      * terminator in the second.  If two key characters are found, we stop at
14299      * the second one in the first pass.  Again this can miss two typos, but
14300      * catches a single one
14301      *
14302      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14303      * point to the first key character.  For the second pass, it starts as -1.
14304      * */
14305
14306     name_start = p;
14307   parse_name:
14308     {
14309         bool has_blank               = FALSE;
14310         bool has_upper               = FALSE;
14311         bool has_terminating_colon   = FALSE;
14312         bool has_terminating_bracket = FALSE;
14313         bool has_semi_colon          = FALSE;
14314         unsigned int name_len        = 0;
14315         int punct_count              = 0;
14316
14317         while (p < e) {
14318
14319             /* Squeeze out blanks when looking up the class name below */
14320             if (isBLANK(*p) ) {
14321                 has_blank = TRUE;
14322                 found_problem = TRUE;
14323                 p++;
14324                 continue;
14325             }
14326
14327             /* The name will end with a punctuation */
14328             if (isPUNCT(*p)) {
14329                 const char * peek = p + 1;
14330
14331                 /* Treat any non-']' punctuation followed by a ']' (possibly
14332                  * with intervening blanks) as trying to terminate the class.
14333                  * ']]' is very likely to mean a class was intended (but
14334                  * missing the colon), but the warning message that gets
14335                  * generated shows the error position better if we exit the
14336                  * loop at the bottom (eventually), so skip it here. */
14337                 if (*p != ']') {
14338                     if (peek < e && isBLANK(*peek)) {
14339                         has_blank = TRUE;
14340                         found_problem = TRUE;
14341                         do {
14342                             peek++;
14343                         } while (peek < e && isBLANK(*peek));
14344                     }
14345
14346                     if (peek < e && *peek == ']') {
14347                         has_terminating_bracket = TRUE;
14348                         if (*p == ':') {
14349                             has_terminating_colon = TRUE;
14350                         }
14351                         else if (*p == ';') {
14352                             has_semi_colon = TRUE;
14353                             has_terminating_colon = TRUE;
14354                         }
14355                         else {
14356                             found_problem = TRUE;
14357                         }
14358                         p = peek + 1;
14359                         goto try_posix;
14360                     }
14361                 }
14362
14363                 /* Here we have punctuation we thought didn't end the class.
14364                  * Keep track of the position of the key characters that are
14365                  * more likely to have been class-enders */
14366                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14367
14368                     /* Allow just one such possible class-ender not actually
14369                      * ending the class. */
14370                     if (possible_end) {
14371                         break;
14372                     }
14373                     possible_end = p;
14374                 }
14375
14376                 /* If we have too many punctuation characters, no use in
14377                  * keeping going */
14378                 if (++punct_count > max_distance) {
14379                     break;
14380                 }
14381
14382                 /* Treat the punctuation as a typo. */
14383                 input_text[name_len++] = *p;
14384                 p++;
14385             }
14386             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14387                 input_text[name_len++] = toLOWER(*p);
14388                 has_upper = TRUE;
14389                 found_problem = TRUE;
14390                 p++;
14391             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14392                 input_text[name_len++] = *p;
14393                 p++;
14394             }
14395             else {
14396                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14397                 p+= UTF8SKIP(p);
14398             }
14399
14400             /* The declaration of 'input_text' is how long we allow a potential
14401              * class name to be, before saying they didn't mean a class name at
14402              * all */
14403             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14404                 break;
14405             }
14406         }
14407
14408         /* We get to here when the possible class name hasn't been properly
14409          * terminated before:
14410          *   1) we ran off the end of the pattern; or
14411          *   2) found two characters, each of which might have been intended to
14412          *      be the name's terminator
14413          *   3) found so many punctuation characters in the purported name,
14414          *      that the edit distance to a valid one is exceeded
14415          *   4) we decided it was more characters than anyone could have
14416          *      intended to be one. */
14417
14418         found_problem = TRUE;
14419
14420         /* In the final two cases, we know that looking up what we've
14421          * accumulated won't lead to a match, even a fuzzy one. */
14422         if (   name_len >= C_ARRAY_LENGTH(input_text)
14423             || punct_count > max_distance)
14424         {
14425             /* If there was an intermediate key character that could have been
14426              * an intended end, redo the parse, but stop there */
14427             if (possible_end && possible_end != (char *) -1) {
14428                 possible_end = (char *) -1; /* Special signal value to say
14429                                                we've done a first pass */
14430                 p = name_start;
14431                 goto parse_name;
14432             }
14433
14434             /* Otherwise, it can't have meant to have been a class */
14435             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14436         }
14437
14438         /* If we ran off the end, and the final character was a punctuation
14439          * one, back up one, to look at that final one just below.  Later, we
14440          * will restore the parse pointer if appropriate */
14441         if (name_len && p == e && isPUNCT(*(p-1))) {
14442             p--;
14443             name_len--;
14444         }
14445
14446         if (p < e && isPUNCT(*p)) {
14447             if (*p == ']') {
14448                 has_terminating_bracket = TRUE;
14449
14450                 /* If this is a 2nd ']', and the first one is just below this
14451                  * one, consider that to be the real terminator.  This gives a
14452                  * uniform and better positioning for the warning message  */
14453                 if (   possible_end
14454                     && possible_end != (char *) -1
14455                     && *possible_end == ']'
14456                     && name_len && input_text[name_len - 1] == ']')
14457                 {
14458                     name_len--;
14459                     p = possible_end;
14460
14461                     /* And this is actually equivalent to having done the 2nd
14462                      * pass now, so set it to not try again */
14463                     possible_end = (char *) -1;
14464                 }
14465             }
14466             else {
14467                 if (*p == ':') {
14468                     has_terminating_colon = TRUE;
14469                 }
14470                 else if (*p == ';') {
14471                     has_semi_colon = TRUE;
14472                     has_terminating_colon = TRUE;
14473                 }
14474                 p++;
14475             }
14476         }
14477
14478     try_posix:
14479
14480         /* Here, we have a class name to look up.  We can short circuit the
14481          * stuff below for short names that can't possibly be meant to be a
14482          * class name.  (We can do this on the first pass, as any second pass
14483          * will yield an even shorter name) */
14484         if (name_len < 3) {
14485             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14486         }
14487
14488         /* Find which class it is.  Initially switch on the length of the name.
14489          * */
14490         switch (name_len) {
14491             case 4:
14492                 if (memEQ(name_start, "word", 4)) {
14493                     /* this is not POSIX, this is the Perl \w */
14494                     class_number = ANYOF_WORDCHAR;
14495                 }
14496                 break;
14497             case 5:
14498                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14499                  *                        graph lower print punct space upper
14500                  * Offset 4 gives the best switch position.  */
14501                 switch (name_start[4]) {
14502                     case 'a':
14503                         if (memEQ(name_start, "alph", 4)) /* alpha */
14504                             class_number = ANYOF_ALPHA;
14505                         break;
14506                     case 'e':
14507                         if (memEQ(name_start, "spac", 4)) /* space */
14508                             class_number = ANYOF_SPACE;
14509                         break;
14510                     case 'h':
14511                         if (memEQ(name_start, "grap", 4)) /* graph */
14512                             class_number = ANYOF_GRAPH;
14513                         break;
14514                     case 'i':
14515                         if (memEQ(name_start, "asci", 4)) /* ascii */
14516                             class_number = ANYOF_ASCII;
14517                         break;
14518                     case 'k':
14519                         if (memEQ(name_start, "blan", 4)) /* blank */
14520                             class_number = ANYOF_BLANK;
14521                         break;
14522                     case 'l':
14523                         if (memEQ(name_start, "cntr", 4)) /* cntrl */
14524                             class_number = ANYOF_CNTRL;
14525                         break;
14526                     case 'm':
14527                         if (memEQ(name_start, "alnu", 4)) /* alnum */
14528                             class_number = ANYOF_ALPHANUMERIC;
14529                         break;
14530                     case 'r':
14531                         if (memEQ(name_start, "lowe", 4)) /* lower */
14532                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
14533                         else if (memEQ(name_start, "uppe", 4)) /* upper */
14534                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
14535                         break;
14536                     case 't':
14537                         if (memEQ(name_start, "digi", 4)) /* digit */
14538                             class_number = ANYOF_DIGIT;
14539                         else if (memEQ(name_start, "prin", 4)) /* print */
14540                             class_number = ANYOF_PRINT;
14541                         else if (memEQ(name_start, "punc", 4)) /* punct */
14542                             class_number = ANYOF_PUNCT;
14543                         break;
14544                 }
14545                 break;
14546             case 6:
14547                 if (memEQ(name_start, "xdigit", 6))
14548                     class_number = ANYOF_XDIGIT;
14549                 break;
14550         }
14551
14552         /* If the name exactly matches a posix class name the class number will
14553          * here be set to it, and the input almost certainly was meant to be a
14554          * posix class, so we can skip further checking.  If instead the syntax
14555          * is exactly correct, but the name isn't one of the legal ones, we
14556          * will return that as an error below.  But if neither of these apply,
14557          * it could be that no posix class was intended at all, or that one
14558          * was, but there was a typo.  We tease these apart by doing fuzzy
14559          * matching on the name */
14560         if (class_number == OOB_NAMEDCLASS && found_problem) {
14561             const UV posix_names[][6] = {
14562                                                 { 'a', 'l', 'n', 'u', 'm' },
14563                                                 { 'a', 'l', 'p', 'h', 'a' },
14564                                                 { 'a', 's', 'c', 'i', 'i' },
14565                                                 { 'b', 'l', 'a', 'n', 'k' },
14566                                                 { 'c', 'n', 't', 'r', 'l' },
14567                                                 { 'd', 'i', 'g', 'i', 't' },
14568                                                 { 'g', 'r', 'a', 'p', 'h' },
14569                                                 { 'l', 'o', 'w', 'e', 'r' },
14570                                                 { 'p', 'r', 'i', 'n', 't' },
14571                                                 { 'p', 'u', 'n', 'c', 't' },
14572                                                 { 's', 'p', 'a', 'c', 'e' },
14573                                                 { 'u', 'p', 'p', 'e', 'r' },
14574                                                 { 'w', 'o', 'r', 'd' },
14575                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
14576                                             };
14577             /* The names of the above all have added NULs to make them the same
14578              * size, so we need to also have the real lengths */
14579             const UV posix_name_lengths[] = {
14580                                                 sizeof("alnum") - 1,
14581                                                 sizeof("alpha") - 1,
14582                                                 sizeof("ascii") - 1,
14583                                                 sizeof("blank") - 1,
14584                                                 sizeof("cntrl") - 1,
14585                                                 sizeof("digit") - 1,
14586                                                 sizeof("graph") - 1,
14587                                                 sizeof("lower") - 1,
14588                                                 sizeof("print") - 1,
14589                                                 sizeof("punct") - 1,
14590                                                 sizeof("space") - 1,
14591                                                 sizeof("upper") - 1,
14592                                                 sizeof("word")  - 1,
14593                                                 sizeof("xdigit")- 1
14594                                             };
14595             unsigned int i;
14596             int temp_max = max_distance;    /* Use a temporary, so if we
14597                                                reparse, we haven't changed the
14598                                                outer one */
14599
14600             /* Use a smaller max edit distance if we are missing one of the
14601              * delimiters */
14602             if (   has_opening_bracket + has_opening_colon < 2
14603                 || has_terminating_bracket + has_terminating_colon < 2)
14604             {
14605                 temp_max--;
14606             }
14607
14608             /* See if the input name is close to a legal one */
14609             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
14610
14611                 /* Short circuit call if the lengths are too far apart to be
14612                  * able to match */
14613                 if (abs( (int) (name_len - posix_name_lengths[i]))
14614                     > temp_max)
14615                 {
14616                     continue;
14617                 }
14618
14619                 if (edit_distance(input_text,
14620                                   posix_names[i],
14621                                   name_len,
14622                                   posix_name_lengths[i],
14623                                   temp_max
14624                                  )
14625                     > -1)
14626                 { /* If it is close, it probably was intended to be a class */
14627                     goto probably_meant_to_be;
14628                 }
14629             }
14630
14631             /* Here the input name is not close enough to a valid class name
14632              * for us to consider it to be intended to be a posix class.  If
14633              * we haven't already done so, and the parse found a character that
14634              * could have been terminators for the name, but which we absorbed
14635              * as typos during the first pass, repeat the parse, signalling it
14636              * to stop at that character */
14637             if (possible_end && possible_end != (char *) -1) {
14638                 possible_end = (char *) -1;
14639                 p = name_start;
14640                 goto parse_name;
14641             }
14642
14643             /* Here neither pass found a close-enough class name */
14644             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14645         }
14646
14647     probably_meant_to_be:
14648
14649         /* Here we think that a posix specification was intended.  Update any
14650          * parse pointer */
14651         if (updated_parse_ptr) {
14652             *updated_parse_ptr = (char *) p;
14653         }
14654
14655         /* If a posix class name was intended but incorrectly specified, we
14656          * output or return the warnings */
14657         if (found_problem) {
14658
14659             /* We set flags for these issues in the parse loop above instead of
14660              * adding them to the list of warnings, because we can parse it
14661              * twice, and we only want one warning instance */
14662             if (has_upper) {
14663                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
14664             }
14665             if (has_blank) {
14666                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14667             }
14668             if (has_semi_colon) {
14669                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14670             }
14671             else if (! has_terminating_colon) {
14672                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
14673             }
14674             if (! has_terminating_bracket) {
14675                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
14676             }
14677
14678             if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
14679                 *posix_warnings = RExC_warn_text;
14680             }
14681         }
14682         else if (class_number != OOB_NAMEDCLASS) {
14683             /* If it is a known class, return the class.  The class number
14684              * #defines are structured so each complement is +1 to the normal
14685              * one */
14686             return class_number + complement;
14687         }
14688         else if (! check_only) {
14689
14690             /* Here, it is an unrecognized class.  This is an error (unless the
14691             * call is to check only, which we've already handled above) */
14692             const char * const complement_string = (complement)
14693                                                    ? "^"
14694                                                    : "";
14695             RExC_parse = (char *) p;
14696             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
14697                         complement_string,
14698                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
14699         }
14700     }
14701
14702     return OOB_NAMEDCLASS;
14703 }
14704 #undef ADD_POSIX_WARNING
14705
14706 STATIC unsigned  int
14707 S_regex_set_precedence(const U8 my_operator) {
14708
14709     /* Returns the precedence in the (?[...]) construct of the input operator,
14710      * specified by its character representation.  The precedence follows
14711      * general Perl rules, but it extends this so that ')' and ']' have (low)
14712      * precedence even though they aren't really operators */
14713
14714     switch (my_operator) {
14715         case '!':
14716             return 5;
14717         case '&':
14718             return 4;
14719         case '^':
14720         case '|':
14721         case '+':
14722         case '-':
14723             return 3;
14724         case ')':
14725             return 2;
14726         case ']':
14727             return 1;
14728     }
14729
14730     NOT_REACHED; /* NOTREACHED */
14731     return 0;   /* Silence compiler warning */
14732 }
14733
14734 STATIC regnode *
14735 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
14736                     I32 *flagp, U32 depth,
14737                     char * const oregcomp_parse)
14738 {
14739     /* Handle the (?[...]) construct to do set operations */
14740
14741     U8 curchar;                     /* Current character being parsed */
14742     UV start, end;                  /* End points of code point ranges */
14743     SV* final = NULL;               /* The end result inversion list */
14744     SV* result_string;              /* 'final' stringified */
14745     AV* stack;                      /* stack of operators and operands not yet
14746                                        resolved */
14747     AV* fence_stack = NULL;         /* A stack containing the positions in
14748                                        'stack' of where the undealt-with left
14749                                        parens would be if they were actually
14750                                        put there */
14751     /* The 'VOL' (expanding to 'volatile') is a workaround for an optimiser bug
14752      * in Solaris Studio 12.3. See RT #127455 */
14753     VOL IV fence = 0;               /* Position of where most recent undealt-
14754                                        with left paren in stack is; -1 if none.
14755                                      */
14756     STRLEN len;                     /* Temporary */
14757     regnode* node;                  /* Temporary, and final regnode returned by
14758                                        this function */
14759     const bool save_fold = FOLD;    /* Temporary */
14760     char *save_end, *save_parse;    /* Temporaries */
14761     const bool in_locale = LOC;     /* we turn off /l during processing */
14762     AV* posix_warnings = NULL;
14763
14764     GET_RE_DEBUG_FLAGS_DECL;
14765
14766     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
14767
14768     if (in_locale) {
14769         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
14770     }
14771
14772     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
14773                                          This is required so that the compile
14774                                          time values are valid in all runtime
14775                                          cases */
14776
14777     /* This will return only an ANYOF regnode, or (unlikely) something smaller
14778      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
14779      * call regclass to handle '[]' so as to not have to reinvent its parsing
14780      * rules here (throwing away the size it computes each time).  And, we exit
14781      * upon an unescaped ']' that isn't one ending a regclass.  To do both
14782      * these things, we need to realize that something preceded by a backslash
14783      * is escaped, so we have to keep track of backslashes */
14784     if (SIZE_ONLY) {
14785         UV depth = 0; /* how many nested (?[...]) constructs */
14786
14787         while (RExC_parse < RExC_end) {
14788             SV* current = NULL;
14789
14790             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14791                                     TRUE /* Force /x */ );
14792
14793             switch (*RExC_parse) {
14794                 case '?':
14795                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
14796                     /* FALLTHROUGH */
14797                 default:
14798                     break;
14799                 case '\\':
14800                     /* Skip past this, so the next character gets skipped, after
14801                      * the switch */
14802                     RExC_parse++;
14803                     if (*RExC_parse == 'c') {
14804                             /* Skip the \cX notation for control characters */
14805                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14806                     }
14807                     break;
14808
14809                 case '[':
14810                 {
14811                     /* See if this is a [:posix:] class. */
14812                     bool is_posix_class = (OOB_NAMEDCLASS
14813                             < handle_possible_posix(pRExC_state,
14814                                                 RExC_parse + 1,
14815                                                 NULL,
14816                                                 NULL,
14817                                                 TRUE /* checking only */));
14818                     /* If it is a posix class, leave the parse pointer at the
14819                      * '[' to fool regclass() into thinking it is part of a
14820                      * '[[:posix:]]'. */
14821                     if (! is_posix_class) {
14822                         RExC_parse++;
14823                     }
14824
14825                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
14826                      * if multi-char folds are allowed.  */
14827                     if (!regclass(pRExC_state, flagp,depth+1,
14828                                   is_posix_class, /* parse the whole char
14829                                                      class only if not a
14830                                                      posix class */
14831                                   FALSE, /* don't allow multi-char folds */
14832                                   TRUE, /* silence non-portable warnings. */
14833                                   TRUE, /* strict */
14834                                   FALSE, /* Require return to be an ANYOF */
14835                                   &current,
14836                                   &posix_warnings
14837                                  ))
14838                         FAIL2("panic: regclass returned NULL to handle_sets, "
14839                               "flags=%#" UVxf, (UV) *flagp);
14840
14841                     /* function call leaves parse pointing to the ']', except
14842                      * if we faked it */
14843                     if (is_posix_class) {
14844                         RExC_parse--;
14845                     }
14846
14847                     SvREFCNT_dec(current);   /* In case it returned something */
14848                     break;
14849                 }
14850
14851                 case ']':
14852                     if (depth--) break;
14853                     RExC_parse++;
14854                     if (*RExC_parse == ')') {
14855                         node = reganode(pRExC_state, ANYOF, 0);
14856                         RExC_size += ANYOF_SKIP;
14857                         nextchar(pRExC_state);
14858                         Set_Node_Length(node,
14859                                 RExC_parse - oregcomp_parse + 1); /* MJD */
14860                         if (in_locale) {
14861                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
14862                         }
14863
14864                         return node;
14865                     }
14866                     goto no_close;
14867             }
14868
14869             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14870         }
14871
14872       no_close:
14873         /* We output the messages even if warnings are off, because we'll fail
14874          * the very next thing, and these give a likely diagnosis for that */
14875         if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
14876             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
14877         }
14878
14879         FAIL("Syntax error in (?[...])");
14880     }
14881
14882     /* Pass 2 only after this. */
14883     Perl_ck_warner_d(aTHX_
14884         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
14885         "The regex_sets feature is experimental" REPORT_LOCATION,
14886         REPORT_LOCATION_ARGS(RExC_parse));
14887
14888     /* Everything in this construct is a metacharacter.  Operands begin with
14889      * either a '\' (for an escape sequence), or a '[' for a bracketed
14890      * character class.  Any other character should be an operator, or
14891      * parenthesis for grouping.  Both types of operands are handled by calling
14892      * regclass() to parse them.  It is called with a parameter to indicate to
14893      * return the computed inversion list.  The parsing here is implemented via
14894      * a stack.  Each entry on the stack is a single character representing one
14895      * of the operators; or else a pointer to an operand inversion list. */
14896
14897 #define IS_OPERATOR(a) SvIOK(a)
14898 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
14899
14900     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
14901      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
14902      * with pronouncing it called it Reverse Polish instead, but now that YOU
14903      * know how to pronounce it you can use the correct term, thus giving due
14904      * credit to the person who invented it, and impressing your geek friends.
14905      * Wikipedia says that the pronounciation of "Ł" has been changing so that
14906      * it is now more like an English initial W (as in wonk) than an L.)
14907      *
14908      * This means that, for example, 'a | b & c' is stored on the stack as
14909      *
14910      * c  [4]
14911      * b  [3]
14912      * &  [2]
14913      * a  [1]
14914      * |  [0]
14915      *
14916      * where the numbers in brackets give the stack [array] element number.
14917      * In this implementation, parentheses are not stored on the stack.
14918      * Instead a '(' creates a "fence" so that the part of the stack below the
14919      * fence is invisible except to the corresponding ')' (this allows us to
14920      * replace testing for parens, by using instead subtraction of the fence
14921      * position).  As new operands are processed they are pushed onto the stack
14922      * (except as noted in the next paragraph).  New operators of higher
14923      * precedence than the current final one are inserted on the stack before
14924      * the lhs operand (so that when the rhs is pushed next, everything will be
14925      * in the correct positions shown above.  When an operator of equal or
14926      * lower precedence is encountered in parsing, all the stacked operations
14927      * of equal or higher precedence are evaluated, leaving the result as the
14928      * top entry on the stack.  This makes higher precedence operations
14929      * evaluate before lower precedence ones, and causes operations of equal
14930      * precedence to left associate.
14931      *
14932      * The only unary operator '!' is immediately pushed onto the stack when
14933      * encountered.  When an operand is encountered, if the top of the stack is
14934      * a '!", the complement is immediately performed, and the '!' popped.  The
14935      * resulting value is treated as a new operand, and the logic in the
14936      * previous paragraph is executed.  Thus in the expression
14937      *      [a] + ! [b]
14938      * the stack looks like
14939      *
14940      * !
14941      * a
14942      * +
14943      *
14944      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
14945      * becomes
14946      *
14947      * !b
14948      * a
14949      * +
14950      *
14951      * A ')' is treated as an operator with lower precedence than all the
14952      * aforementioned ones, which causes all operations on the stack above the
14953      * corresponding '(' to be evaluated down to a single resultant operand.
14954      * Then the fence for the '(' is removed, and the operand goes through the
14955      * algorithm above, without the fence.
14956      *
14957      * A separate stack is kept of the fence positions, so that the position of
14958      * the latest so-far unbalanced '(' is at the top of it.
14959      *
14960      * The ']' ending the construct is treated as the lowest operator of all,
14961      * so that everything gets evaluated down to a single operand, which is the
14962      * result */
14963
14964     sv_2mortal((SV *)(stack = newAV()));
14965     sv_2mortal((SV *)(fence_stack = newAV()));
14966
14967     while (RExC_parse < RExC_end) {
14968         I32 top_index;              /* Index of top-most element in 'stack' */
14969         SV** top_ptr;               /* Pointer to top 'stack' element */
14970         SV* current = NULL;         /* To contain the current inversion list
14971                                        operand */
14972         SV* only_to_avoid_leaks;
14973
14974         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14975                                 TRUE /* Force /x */ );
14976         if (RExC_parse >= RExC_end) {
14977             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
14978         }
14979
14980         curchar = UCHARAT(RExC_parse);
14981
14982 redo_curchar:
14983
14984 #ifdef ENABLE_REGEX_SETS_DEBUGGING
14985                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
14986         DEBUG_U(dump_regex_sets_structures(pRExC_state,
14987                                            stack, fence, fence_stack));
14988 #endif
14989
14990         top_index = av_tindex_skip_len_mg(stack);
14991
14992         switch (curchar) {
14993             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
14994             char stacked_operator;  /* The topmost operator on the 'stack'. */
14995             SV* lhs;                /* Operand to the left of the operator */
14996             SV* rhs;                /* Operand to the right of the operator */
14997             SV* fence_ptr;          /* Pointer to top element of the fence
14998                                        stack */
14999
15000             case '(':
15001
15002                 if (   RExC_parse < RExC_end - 1
15003                     && (UCHARAT(RExC_parse + 1) == '?'))
15004                 {
15005                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
15006                      * This happens when we have some thing like
15007                      *
15008                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
15009                      *   ...
15010                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
15011                      *
15012                      * Here we would be handling the interpolated
15013                      * '$thai_or_lao'.  We handle this by a recursive call to
15014                      * ourselves which returns the inversion list the
15015                      * interpolated expression evaluates to.  We use the flags
15016                      * from the interpolated pattern. */
15017                     U32 save_flags = RExC_flags;
15018                     const char * save_parse;
15019
15020                     RExC_parse += 2;        /* Skip past the '(?' */
15021                     save_parse = RExC_parse;
15022
15023                     /* Parse any flags for the '(?' */
15024                     parse_lparen_question_flags(pRExC_state);
15025
15026                     if (RExC_parse == save_parse  /* Makes sure there was at
15027                                                      least one flag (or else
15028                                                      this embedding wasn't
15029                                                      compiled) */
15030                         || RExC_parse >= RExC_end - 4
15031                         || UCHARAT(RExC_parse) != ':'
15032                         || UCHARAT(++RExC_parse) != '('
15033                         || UCHARAT(++RExC_parse) != '?'
15034                         || UCHARAT(++RExC_parse) != '[')
15035                     {
15036
15037                         /* In combination with the above, this moves the
15038                          * pointer to the point just after the first erroneous
15039                          * character (or if there are no flags, to where they
15040                          * should have been) */
15041                         if (RExC_parse >= RExC_end - 4) {
15042                             RExC_parse = RExC_end;
15043                         }
15044                         else if (RExC_parse != save_parse) {
15045                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15046                         }
15047                         vFAIL("Expecting '(?flags:(?[...'");
15048                     }
15049
15050                     /* Recurse, with the meat of the embedded expression */
15051                     RExC_parse++;
15052                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15053                                                     depth+1, oregcomp_parse);
15054
15055                     /* Here, 'current' contains the embedded expression's
15056                      * inversion list, and RExC_parse points to the trailing
15057                      * ']'; the next character should be the ')' */
15058                     RExC_parse++;
15059                     assert(UCHARAT(RExC_parse) == ')');
15060
15061                     /* Then the ')' matching the original '(' handled by this
15062                      * case: statement */
15063                     RExC_parse++;
15064                     assert(UCHARAT(RExC_parse) == ')');
15065
15066                     RExC_parse++;
15067                     RExC_flags = save_flags;
15068                     goto handle_operand;
15069                 }
15070
15071                 /* A regular '('.  Look behind for illegal syntax */
15072                 if (top_index - fence >= 0) {
15073                     /* If the top entry on the stack is an operator, it had
15074                      * better be a '!', otherwise the entry below the top
15075                      * operand should be an operator */
15076                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15077                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15078                         || (   IS_OPERAND(*top_ptr)
15079                             && (   top_index - fence < 1
15080                                 || ! (stacked_ptr = av_fetch(stack,
15081                                                              top_index - 1,
15082                                                              FALSE))
15083                                 || ! IS_OPERATOR(*stacked_ptr))))
15084                     {
15085                         RExC_parse++;
15086                         vFAIL("Unexpected '(' with no preceding operator");
15087                     }
15088                 }
15089
15090                 /* Stack the position of this undealt-with left paren */
15091                 av_push(fence_stack, newSViv(fence));
15092                 fence = top_index + 1;
15093                 break;
15094
15095             case '\\':
15096                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15097                  * multi-char folds are allowed.  */
15098                 if (!regclass(pRExC_state, flagp,depth+1,
15099                               TRUE, /* means parse just the next thing */
15100                               FALSE, /* don't allow multi-char folds */
15101                               FALSE, /* don't silence non-portable warnings.  */
15102                               TRUE,  /* strict */
15103                               FALSE, /* Require return to be an ANYOF */
15104                               &current,
15105                               NULL))
15106                 {
15107                     FAIL2("panic: regclass returned NULL to handle_sets, "
15108                           "flags=%#" UVxf, (UV) *flagp);
15109                 }
15110
15111                 /* regclass() will return with parsing just the \ sequence,
15112                  * leaving the parse pointer at the next thing to parse */
15113                 RExC_parse--;
15114                 goto handle_operand;
15115
15116             case '[':   /* Is a bracketed character class */
15117             {
15118                 /* See if this is a [:posix:] class. */
15119                 bool is_posix_class = (OOB_NAMEDCLASS
15120                             < handle_possible_posix(pRExC_state,
15121                                                 RExC_parse + 1,
15122                                                 NULL,
15123                                                 NULL,
15124                                                 TRUE /* checking only */));
15125                 /* If it is a posix class, leave the parse pointer at the '['
15126                  * to fool regclass() into thinking it is part of a
15127                  * '[[:posix:]]'. */
15128                 if (! is_posix_class) {
15129                     RExC_parse++;
15130                 }
15131
15132                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15133                  * multi-char folds are allowed.  */
15134                 if (!regclass(pRExC_state, flagp,depth+1,
15135                                 is_posix_class, /* parse the whole char
15136                                                     class only if not a
15137                                                     posix class */
15138                                 FALSE, /* don't allow multi-char folds */
15139                                 TRUE, /* silence non-portable warnings. */
15140                                 TRUE, /* strict */
15141                                 FALSE, /* Require return to be an ANYOF */
15142                                 &current,
15143                                 NULL
15144                                 ))
15145                 {
15146                     FAIL2("panic: regclass returned NULL to handle_sets, "
15147                           "flags=%#" UVxf, (UV) *flagp);
15148                 }
15149
15150                 /* function call leaves parse pointing to the ']', except if we
15151                  * faked it */
15152                 if (is_posix_class) {
15153                     RExC_parse--;
15154                 }
15155
15156                 goto handle_operand;
15157             }
15158
15159             case ']':
15160                 if (top_index >= 1) {
15161                     goto join_operators;
15162                 }
15163
15164                 /* Only a single operand on the stack: are done */
15165                 goto done;
15166
15167             case ')':
15168                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
15169                     RExC_parse++;
15170                     vFAIL("Unexpected ')'");
15171                 }
15172
15173                 /* If nothing after the fence, is missing an operand */
15174                 if (top_index - fence < 0) {
15175                     RExC_parse++;
15176                     goto bad_syntax;
15177                 }
15178                 /* If at least two things on the stack, treat this as an
15179                   * operator */
15180                 if (top_index - fence >= 1) {
15181                     goto join_operators;
15182                 }
15183
15184                 /* Here only a single thing on the fenced stack, and there is a
15185                  * fence.  Get rid of it */
15186                 fence_ptr = av_pop(fence_stack);
15187                 assert(fence_ptr);
15188                 fence = SvIV(fence_ptr) - 1;
15189                 SvREFCNT_dec_NN(fence_ptr);
15190                 fence_ptr = NULL;
15191
15192                 if (fence < 0) {
15193                     fence = 0;
15194                 }
15195
15196                 /* Having gotten rid of the fence, we pop the operand at the
15197                  * stack top and process it as a newly encountered operand */
15198                 current = av_pop(stack);
15199                 if (IS_OPERAND(current)) {
15200                     goto handle_operand;
15201                 }
15202
15203                 RExC_parse++;
15204                 goto bad_syntax;
15205
15206             case '&':
15207             case '|':
15208             case '+':
15209             case '-':
15210             case '^':
15211
15212                 /* These binary operators should have a left operand already
15213                  * parsed */
15214                 if (   top_index - fence < 0
15215                     || top_index - fence == 1
15216                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15217                     || ! IS_OPERAND(*top_ptr))
15218                 {
15219                     goto unexpected_binary;
15220                 }
15221
15222                 /* If only the one operand is on the part of the stack visible
15223                  * to us, we just place this operator in the proper position */
15224                 if (top_index - fence < 2) {
15225
15226                     /* Place the operator before the operand */
15227
15228                     SV* lhs = av_pop(stack);
15229                     av_push(stack, newSVuv(curchar));
15230                     av_push(stack, lhs);
15231                     break;
15232                 }
15233
15234                 /* But if there is something else on the stack, we need to
15235                  * process it before this new operator if and only if the
15236                  * stacked operation has equal or higher precedence than the
15237                  * new one */
15238
15239              join_operators:
15240
15241                 /* The operator on the stack is supposed to be below both its
15242                  * operands */
15243                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15244                     || IS_OPERAND(*stacked_ptr))
15245                 {
15246                     /* But if not, it's legal and indicates we are completely
15247                      * done if and only if we're currently processing a ']',
15248                      * which should be the final thing in the expression */
15249                     if (curchar == ']') {
15250                         goto done;
15251                     }
15252
15253                   unexpected_binary:
15254                     RExC_parse++;
15255                     vFAIL2("Unexpected binary operator '%c' with no "
15256                            "preceding operand", curchar);
15257                 }
15258                 stacked_operator = (char) SvUV(*stacked_ptr);
15259
15260                 if (regex_set_precedence(curchar)
15261                     > regex_set_precedence(stacked_operator))
15262                 {
15263                     /* Here, the new operator has higher precedence than the
15264                      * stacked one.  This means we need to add the new one to
15265                      * the stack to await its rhs operand (and maybe more
15266                      * stuff).  We put it before the lhs operand, leaving
15267                      * untouched the stacked operator and everything below it
15268                      * */
15269                     lhs = av_pop(stack);
15270                     assert(IS_OPERAND(lhs));
15271
15272                     av_push(stack, newSVuv(curchar));
15273                     av_push(stack, lhs);
15274                     break;
15275                 }
15276
15277                 /* Here, the new operator has equal or lower precedence than
15278                  * what's already there.  This means the operation already
15279                  * there should be performed now, before the new one. */
15280
15281                 rhs = av_pop(stack);
15282                 if (! IS_OPERAND(rhs)) {
15283
15284                     /* This can happen when a ! is not followed by an operand,
15285                      * like in /(?[\t &!])/ */
15286                     goto bad_syntax;
15287                 }
15288
15289                 lhs = av_pop(stack);
15290
15291                 if (! IS_OPERAND(lhs)) {
15292
15293                     /* This can happen when there is an empty (), like in
15294                      * /(?[[0]+()+])/ */
15295                     goto bad_syntax;
15296                 }
15297
15298                 switch (stacked_operator) {
15299                     case '&':
15300                         _invlist_intersection(lhs, rhs, &rhs);
15301                         break;
15302
15303                     case '|':
15304                     case '+':
15305                         _invlist_union(lhs, rhs, &rhs);
15306                         break;
15307
15308                     case '-':
15309                         _invlist_subtract(lhs, rhs, &rhs);
15310                         break;
15311
15312                     case '^':   /* The union minus the intersection */
15313                     {
15314                         SV* i = NULL;
15315                         SV* u = NULL;
15316
15317                         _invlist_union(lhs, rhs, &u);
15318                         _invlist_intersection(lhs, rhs, &i);
15319                         _invlist_subtract(u, i, &rhs);
15320                         SvREFCNT_dec_NN(i);
15321                         SvREFCNT_dec_NN(u);
15322                         break;
15323                     }
15324                 }
15325                 SvREFCNT_dec(lhs);
15326
15327                 /* Here, the higher precedence operation has been done, and the
15328                  * result is in 'rhs'.  We overwrite the stacked operator with
15329                  * the result.  Then we redo this code to either push the new
15330                  * operator onto the stack or perform any higher precedence
15331                  * stacked operation */
15332                 only_to_avoid_leaks = av_pop(stack);
15333                 SvREFCNT_dec(only_to_avoid_leaks);
15334                 av_push(stack, rhs);
15335                 goto redo_curchar;
15336
15337             case '!':   /* Highest priority, right associative */
15338
15339                 /* If what's already at the top of the stack is another '!",
15340                  * they just cancel each other out */
15341                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15342                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15343                 {
15344                     only_to_avoid_leaks = av_pop(stack);
15345                     SvREFCNT_dec(only_to_avoid_leaks);
15346                 }
15347                 else { /* Otherwise, since it's right associative, just push
15348                           onto the stack */
15349                     av_push(stack, newSVuv(curchar));
15350                 }
15351                 break;
15352
15353             default:
15354                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15355                 vFAIL("Unexpected character");
15356
15357           handle_operand:
15358
15359             /* Here 'current' is the operand.  If something is already on the
15360              * stack, we have to check if it is a !.  But first, the code above
15361              * may have altered the stack in the time since we earlier set
15362              * 'top_index'.  */
15363
15364             top_index = av_tindex_skip_len_mg(stack);
15365             if (top_index - fence >= 0) {
15366                 /* If the top entry on the stack is an operator, it had better
15367                  * be a '!', otherwise the entry below the top operand should
15368                  * be an operator */
15369                 top_ptr = av_fetch(stack, top_index, FALSE);
15370                 assert(top_ptr);
15371                 if (IS_OPERATOR(*top_ptr)) {
15372
15373                     /* The only permissible operator at the top of the stack is
15374                      * '!', which is applied immediately to this operand. */
15375                     curchar = (char) SvUV(*top_ptr);
15376                     if (curchar != '!') {
15377                         SvREFCNT_dec(current);
15378                         vFAIL2("Unexpected binary operator '%c' with no "
15379                                 "preceding operand", curchar);
15380                     }
15381
15382                     _invlist_invert(current);
15383
15384                     only_to_avoid_leaks = av_pop(stack);
15385                     SvREFCNT_dec(only_to_avoid_leaks);
15386
15387                     /* And we redo with the inverted operand.  This allows
15388                      * handling multiple ! in a row */
15389                     goto handle_operand;
15390                 }
15391                           /* Single operand is ok only for the non-binary ')'
15392                            * operator */
15393                 else if ((top_index - fence == 0 && curchar != ')')
15394                          || (top_index - fence > 0
15395                              && (! (stacked_ptr = av_fetch(stack,
15396                                                            top_index - 1,
15397                                                            FALSE))
15398                                  || IS_OPERAND(*stacked_ptr))))
15399                 {
15400                     SvREFCNT_dec(current);
15401                     vFAIL("Operand with no preceding operator");
15402                 }
15403             }
15404
15405             /* Here there was nothing on the stack or the top element was
15406              * another operand.  Just add this new one */
15407             av_push(stack, current);
15408
15409         } /* End of switch on next parse token */
15410
15411         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15412     } /* End of loop parsing through the construct */
15413
15414   done:
15415     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
15416         vFAIL("Unmatched (");
15417     }
15418
15419     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
15420         || ((final = av_pop(stack)) == NULL)
15421         || ! IS_OPERAND(final)
15422         || SvTYPE(final) != SVt_INVLIST
15423         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
15424     {
15425       bad_syntax:
15426         SvREFCNT_dec(final);
15427         vFAIL("Incomplete expression within '(?[ ])'");
15428     }
15429
15430     /* Here, 'final' is the resultant inversion list from evaluating the
15431      * expression.  Return it if so requested */
15432     if (return_invlist) {
15433         *return_invlist = final;
15434         return END;
15435     }
15436
15437     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15438      * expecting a string of ranges and individual code points */
15439     invlist_iterinit(final);
15440     result_string = newSVpvs("");
15441     while (invlist_iternext(final, &start, &end)) {
15442         if (start == end) {
15443             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
15444         }
15445         else {
15446             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
15447                                                      start,          end);
15448         }
15449     }
15450
15451     /* About to generate an ANYOF (or similar) node from the inversion list we
15452      * have calculated */
15453     save_parse = RExC_parse;
15454     RExC_parse = SvPV(result_string, len);
15455     save_end = RExC_end;
15456     RExC_end = RExC_parse + len;
15457
15458     /* We turn off folding around the call, as the class we have constructed
15459      * already has all folding taken into consideration, and we don't want
15460      * regclass() to add to that */
15461     RExC_flags &= ~RXf_PMf_FOLD;
15462     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15463      * folds are allowed.  */
15464     node = regclass(pRExC_state, flagp,depth+1,
15465                     FALSE, /* means parse the whole char class */
15466                     FALSE, /* don't allow multi-char folds */
15467                     TRUE, /* silence non-portable warnings.  The above may very
15468                              well have generated non-portable code points, but
15469                              they're valid on this machine */
15470                     FALSE, /* similarly, no need for strict */
15471                     FALSE, /* Require return to be an ANYOF */
15472                     NULL,
15473                     NULL
15474                 );
15475     if (!node)
15476         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#" UVxf,
15477                     PTR2UV(flagp));
15478
15479     /* Fix up the node type if we are in locale.  (We have pretended we are
15480      * under /u for the purposes of regclass(), as this construct will only
15481      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15482      * as to cause any warnings about bad locales to be output in regexec.c),
15483      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15484      * reason we above forbid optimization into something other than an ANYOF
15485      * node is simply to minimize the number of code changes in regexec.c.
15486      * Otherwise we would have to create new EXACTish node types and deal with
15487      * them.  This decision could be revisited should this construct become
15488      * popular.
15489      *
15490      * (One might think we could look at the resulting ANYOF node and suppress
15491      * the flag if everything is above 255, as those would be UTF-8 only,
15492      * but this isn't true, as the components that led to that result could
15493      * have been locale-affected, and just happen to cancel each other out
15494      * under UTF-8 locales.) */
15495     if (in_locale) {
15496         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15497
15498         assert(OP(node) == ANYOF);
15499
15500         OP(node) = ANYOFL;
15501         ANYOF_FLAGS(node)
15502                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
15503     }
15504
15505     if (save_fold) {
15506         RExC_flags |= RXf_PMf_FOLD;
15507     }
15508
15509     RExC_parse = save_parse + 1;
15510     RExC_end = save_end;
15511     SvREFCNT_dec_NN(final);
15512     SvREFCNT_dec_NN(result_string);
15513
15514     nextchar(pRExC_state);
15515     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
15516     return node;
15517 }
15518
15519 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15520
15521 STATIC void
15522 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
15523                              AV * stack, const IV fence, AV * fence_stack)
15524 {   /* Dumps the stacks in handle_regex_sets() */
15525
15526     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
15527     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
15528     SSize_t i;
15529
15530     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
15531
15532     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
15533
15534     if (stack_top < 0) {
15535         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
15536     }
15537     else {
15538         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
15539         for (i = stack_top; i >= 0; i--) {
15540             SV ** element_ptr = av_fetch(stack, i, FALSE);
15541             if (! element_ptr) {
15542             }
15543
15544             if (IS_OPERATOR(*element_ptr)) {
15545                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
15546                                             (int) i, (int) SvIV(*element_ptr));
15547             }
15548             else {
15549                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
15550                 sv_dump(*element_ptr);
15551             }
15552         }
15553     }
15554
15555     if (fence_stack_top < 0) {
15556         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
15557     }
15558     else {
15559         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
15560         for (i = fence_stack_top; i >= 0; i--) {
15561             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
15562             if (! element_ptr) {
15563             }
15564
15565             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
15566                                             (int) i, (int) SvIV(*element_ptr));
15567         }
15568     }
15569 }
15570
15571 #endif
15572
15573 #undef IS_OPERATOR
15574 #undef IS_OPERAND
15575
15576 STATIC void
15577 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
15578 {
15579     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
15580      * innocent-looking character class, like /[ks]/i won't have to go out to
15581      * disk to find the possible matches.
15582      *
15583      * This should be called only for a Latin1-range code points, cp, which is
15584      * known to be involved in a simple fold with other code points above
15585      * Latin1.  It would give false results if /aa has been specified.
15586      * Multi-char folds are outside the scope of this, and must be handled
15587      * specially.
15588      *
15589      * XXX It would be better to generate these via regen, in case a new
15590      * version of the Unicode standard adds new mappings, though that is not
15591      * really likely, and may be caught by the default: case of the switch
15592      * below. */
15593
15594     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
15595
15596     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
15597
15598     switch (cp) {
15599         case 'k':
15600         case 'K':
15601           *invlist =
15602              add_cp_to_invlist(*invlist, KELVIN_SIGN);
15603             break;
15604         case 's':
15605         case 'S':
15606           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
15607             break;
15608         case MICRO_SIGN:
15609           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
15610           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
15611             break;
15612         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
15613         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
15614           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
15615             break;
15616         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
15617           *invlist = add_cp_to_invlist(*invlist,
15618                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
15619             break;
15620
15621 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
15622
15623         case LATIN_SMALL_LETTER_SHARP_S:
15624           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
15625             break;
15626
15627 #endif
15628
15629 #if    UNICODE_MAJOR_VERSION < 3                                        \
15630    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
15631
15632         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
15633          * U+0131.  */
15634         case 'i':
15635         case 'I':
15636           *invlist =
15637              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
15638 #   if UNICODE_DOT_DOT_VERSION == 1
15639           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
15640 #   endif
15641             break;
15642 #endif
15643
15644         default:
15645             /* Use deprecated warning to increase the chances of this being
15646              * output */
15647             if (PASS2) {
15648                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
15649             }
15650             break;
15651     }
15652 }
15653
15654 STATIC void
15655 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
15656 {
15657     /* If the final parameter is NULL, output the elements of the array given
15658      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
15659      * pushed onto it, (creating if necessary) */
15660
15661     SV * msg;
15662     const bool first_is_fatal =  ! return_posix_warnings
15663                                 && ckDEAD(packWARN(WARN_REGEXP));
15664
15665     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
15666
15667     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
15668         if (return_posix_warnings) {
15669             if (! *return_posix_warnings) { /* mortalize to not leak if
15670                                                warnings are fatal */
15671                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
15672             }
15673             av_push(*return_posix_warnings, msg);
15674         }
15675         else {
15676             if (first_is_fatal) {           /* Avoid leaking this */
15677                 av_undef(posix_warnings);   /* This isn't necessary if the
15678                                                array is mortal, but is a
15679                                                fail-safe */
15680                 (void) sv_2mortal(msg);
15681                 if (PASS2) {
15682                     SAVEFREESV(RExC_rx_sv);
15683                 }
15684             }
15685             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
15686             SvREFCNT_dec_NN(msg);
15687         }
15688     }
15689 }
15690
15691 STATIC AV *
15692 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
15693 {
15694     /* This adds the string scalar <multi_string> to the array
15695      * <multi_char_matches>.  <multi_string> is known to have exactly
15696      * <cp_count> code points in it.  This is used when constructing a
15697      * bracketed character class and we find something that needs to match more
15698      * than a single character.
15699      *
15700      * <multi_char_matches> is actually an array of arrays.  Each top-level
15701      * element is an array that contains all the strings known so far that are
15702      * the same length.  And that length (in number of code points) is the same
15703      * as the index of the top-level array.  Hence, the [2] element is an
15704      * array, each element thereof is a string containing TWO code points;
15705      * while element [3] is for strings of THREE characters, and so on.  Since
15706      * this is for multi-char strings there can never be a [0] nor [1] element.
15707      *
15708      * When we rewrite the character class below, we will do so such that the
15709      * longest strings are written first, so that it prefers the longest
15710      * matching strings first.  This is done even if it turns out that any
15711      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
15712      * Christiansen has agreed that this is ok.  This makes the test for the
15713      * ligature 'ffi' come before the test for 'ff', for example */
15714
15715     AV* this_array;
15716     AV** this_array_ptr;
15717
15718     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
15719
15720     if (! multi_char_matches) {
15721         multi_char_matches = newAV();
15722     }
15723
15724     if (av_exists(multi_char_matches, cp_count)) {
15725         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
15726         this_array = *this_array_ptr;
15727     }
15728     else {
15729         this_array = newAV();
15730         av_store(multi_char_matches, cp_count,
15731                  (SV*) this_array);
15732     }
15733     av_push(this_array, multi_string);
15734
15735     return multi_char_matches;
15736 }
15737
15738 /* The names of properties whose definitions are not known at compile time are
15739  * stored in this SV, after a constant heading.  So if the length has been
15740  * changed since initialization, then there is a run-time definition. */
15741 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
15742                                         (SvCUR(listsv) != initial_listsv_len)
15743
15744 /* There is a restricted set of white space characters that are legal when
15745  * ignoring white space in a bracketed character class.  This generates the
15746  * code to skip them.
15747  *
15748  * There is a line below that uses the same white space criteria but is outside
15749  * this macro.  Both here and there must use the same definition */
15750 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
15751     STMT_START {                                                        \
15752         if (do_skip) {                                                  \
15753             while (isBLANK_A(UCHARAT(p)))                               \
15754             {                                                           \
15755                 p++;                                                    \
15756             }                                                           \
15757         }                                                               \
15758     } STMT_END
15759
15760 STATIC regnode *
15761 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
15762                  const bool stop_at_1,  /* Just parse the next thing, don't
15763                                            look for a full character class */
15764                  bool allow_multi_folds,
15765                  const bool silence_non_portable,   /* Don't output warnings
15766                                                        about too large
15767                                                        characters */
15768                  const bool strict,
15769                  bool optimizable,                  /* ? Allow a non-ANYOF return
15770                                                        node */
15771                  SV** ret_invlist, /* Return an inversion list, not a node */
15772                  AV** return_posix_warnings
15773           )
15774 {
15775     /* parse a bracketed class specification.  Most of these will produce an
15776      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
15777      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
15778      * under /i with multi-character folds: it will be rewritten following the
15779      * paradigm of this example, where the <multi-fold>s are characters which
15780      * fold to multiple character sequences:
15781      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
15782      * gets effectively rewritten as:
15783      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
15784      * reg() gets called (recursively) on the rewritten version, and this
15785      * function will return what it constructs.  (Actually the <multi-fold>s
15786      * aren't physically removed from the [abcdefghi], it's just that they are
15787      * ignored in the recursion by means of a flag:
15788      * <RExC_in_multi_char_class>.)
15789      *
15790      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
15791      * characters, with the corresponding bit set if that character is in the
15792      * list.  For characters above this, a range list or swash is used.  There
15793      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
15794      * determinable at compile time
15795      *
15796      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
15797      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
15798      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
15799      */
15800
15801     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
15802     IV range = 0;
15803     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
15804     regnode *ret;
15805     STRLEN numlen;
15806     int namedclass = OOB_NAMEDCLASS;
15807     char *rangebegin = NULL;
15808     bool need_class = 0;
15809     SV *listsv = NULL;
15810     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
15811                                       than just initialized.  */
15812     SV* properties = NULL;    /* Code points that match \p{} \P{} */
15813     SV* posixes = NULL;     /* Code points that match classes like [:word:],
15814                                extended beyond the Latin1 range.  These have to
15815                                be kept separate from other code points for much
15816                                of this function because their handling  is
15817                                different under /i, and for most classes under
15818                                /d as well */
15819     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
15820                                separate for a while from the non-complemented
15821                                versions because of complications with /d
15822                                matching */
15823     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
15824                                   treated more simply than the general case,
15825                                   leading to less compilation and execution
15826                                   work */
15827     UV element_count = 0;   /* Number of distinct elements in the class.
15828                                Optimizations may be possible if this is tiny */
15829     AV * multi_char_matches = NULL; /* Code points that fold to more than one
15830                                        character; used under /i */
15831     UV n;
15832     char * stop_ptr = RExC_end;    /* where to stop parsing */
15833
15834     /* ignore unescaped whitespace? */
15835     const bool skip_white = cBOOL(   ret_invlist
15836                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
15837
15838     /* Unicode properties are stored in a swash; this holds the current one
15839      * being parsed.  If this swash is the only above-latin1 component of the
15840      * character class, an optimization is to pass it directly on to the
15841      * execution engine.  Otherwise, it is set to NULL to indicate that there
15842      * are other things in the class that have to be dealt with at execution
15843      * time */
15844     SV* swash = NULL;           /* Code points that match \p{} \P{} */
15845
15846     /* Set if a component of this character class is user-defined; just passed
15847      * on to the engine */
15848     bool has_user_defined_property = FALSE;
15849
15850     /* inversion list of code points this node matches only when the target
15851      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
15852      * /d) */
15853     SV* has_upper_latin1_only_utf8_matches = NULL;
15854
15855     /* Inversion list of code points this node matches regardless of things
15856      * like locale, folding, utf8ness of the target string */
15857     SV* cp_list = NULL;
15858
15859     /* Like cp_list, but code points on this list need to be checked for things
15860      * that fold to/from them under /i */
15861     SV* cp_foldable_list = NULL;
15862
15863     /* Like cp_list, but code points on this list are valid only when the
15864      * runtime locale is UTF-8 */
15865     SV* only_utf8_locale_list = NULL;
15866
15867     /* In a range, if one of the endpoints is non-character-set portable,
15868      * meaning that it hard-codes a code point that may mean a different
15869      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
15870      * mnemonic '\t' which each mean the same character no matter which
15871      * character set the platform is on. */
15872     unsigned int non_portable_endpoint = 0;
15873
15874     /* Is the range unicode? which means on a platform that isn't 1-1 native
15875      * to Unicode (i.e. non-ASCII), each code point in it should be considered
15876      * to be a Unicode value.  */
15877     bool unicode_range = FALSE;
15878     bool invert = FALSE;    /* Is this class to be complemented */
15879
15880     bool warn_super = ALWAYS_WARN_SUPER;
15881
15882     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
15883         case we need to change the emitted regop to an EXACT. */
15884     const char * orig_parse = RExC_parse;
15885     const SSize_t orig_size = RExC_size;
15886     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
15887
15888     /* This variable is used to mark where the end in the input is of something
15889      * that looks like a POSIX construct but isn't.  During the parse, when
15890      * something looks like it could be such a construct is encountered, it is
15891      * checked for being one, but not if we've already checked this area of the
15892      * input.  Only after this position is reached do we check again */
15893     char *not_posix_region_end = RExC_parse - 1;
15894
15895     AV* posix_warnings = NULL;
15896     const bool do_posix_warnings =     return_posix_warnings
15897                                    || (PASS2 && ckWARN(WARN_REGEXP));
15898
15899     GET_RE_DEBUG_FLAGS_DECL;
15900
15901     PERL_ARGS_ASSERT_REGCLASS;
15902 #ifndef DEBUGGING
15903     PERL_UNUSED_ARG(depth);
15904 #endif
15905
15906     DEBUG_PARSE("clas");
15907
15908 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
15909     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
15910                                    && UNICODE_DOT_DOT_VERSION == 0)
15911     allow_multi_folds = FALSE;
15912 #endif
15913
15914     /* Assume we are going to generate an ANYOF node. */
15915     ret = reganode(pRExC_state,
15916                    (LOC)
15917                     ? ANYOFL
15918                     : ANYOF,
15919                    0);
15920
15921     if (SIZE_ONLY) {
15922         RExC_size += ANYOF_SKIP;
15923         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
15924     }
15925     else {
15926         ANYOF_FLAGS(ret) = 0;
15927
15928         RExC_emit += ANYOF_SKIP;
15929         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
15930         initial_listsv_len = SvCUR(listsv);
15931         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
15932     }
15933
15934     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15935
15936     assert(RExC_parse <= RExC_end);
15937
15938     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
15939         RExC_parse++;
15940         invert = TRUE;
15941         allow_multi_folds = FALSE;
15942         MARK_NAUGHTY(1);
15943         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15944     }
15945
15946     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
15947     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
15948         int maybe_class = handle_possible_posix(pRExC_state,
15949                                                 RExC_parse,
15950                                                 &not_posix_region_end,
15951                                                 NULL,
15952                                                 TRUE /* checking only */);
15953         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
15954             SAVEFREESV(RExC_rx_sv);
15955             ckWARN4reg(not_posix_region_end,
15956                     "POSIX syntax [%c %c] belongs inside character classes%s",
15957                     *RExC_parse, *RExC_parse,
15958                     (maybe_class == OOB_NAMEDCLASS)
15959                     ? ((POSIXCC_NOTYET(*RExC_parse))
15960                         ? " (but this one isn't implemented)"
15961                         : " (but this one isn't fully valid)")
15962                     : ""
15963                     );
15964             (void)ReREFCNT_inc(RExC_rx_sv);
15965         }
15966     }
15967
15968     /* If the caller wants us to just parse a single element, accomplish this
15969      * by faking the loop ending condition */
15970     if (stop_at_1 && RExC_end > RExC_parse) {
15971         stop_ptr = RExC_parse + 1;
15972     }
15973
15974     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
15975     if (UCHARAT(RExC_parse) == ']')
15976         goto charclassloop;
15977
15978     while (1) {
15979
15980         if (   posix_warnings
15981             && av_tindex_skip_len_mg(posix_warnings) >= 0
15982             && RExC_parse > not_posix_region_end)
15983         {
15984             /* Warnings about posix class issues are considered tentative until
15985              * we are far enough along in the parse that we can no longer
15986              * change our mind, at which point we either output them or add
15987              * them, if it has so specified, to what gets returned to the
15988              * caller.  This is done each time through the loop so that a later
15989              * class won't zap them before they have been dealt with. */
15990             output_or_return_posix_warnings(pRExC_state, posix_warnings,
15991                                             return_posix_warnings);
15992         }
15993
15994         if  (RExC_parse >= stop_ptr) {
15995             break;
15996         }
15997
15998         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15999
16000         if  (UCHARAT(RExC_parse) == ']') {
16001             break;
16002         }
16003
16004       charclassloop:
16005
16006         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
16007         save_value = value;
16008         save_prevvalue = prevvalue;
16009
16010         if (!range) {
16011             rangebegin = RExC_parse;
16012             element_count++;
16013             non_portable_endpoint = 0;
16014         }
16015         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
16016             value = utf8n_to_uvchr((U8*)RExC_parse,
16017                                    RExC_end - RExC_parse,
16018                                    &numlen, UTF8_ALLOW_DEFAULT);
16019             RExC_parse += numlen;
16020         }
16021         else
16022             value = UCHARAT(RExC_parse++);
16023
16024         if (value == '[') {
16025             char * posix_class_end;
16026             namedclass = handle_possible_posix(pRExC_state,
16027                                                RExC_parse,
16028                                                &posix_class_end,
16029                                                do_posix_warnings ? &posix_warnings : NULL,
16030                                                FALSE    /* die if error */);
16031             if (namedclass > OOB_NAMEDCLASS) {
16032
16033                 /* If there was an earlier attempt to parse this particular
16034                  * posix class, and it failed, it was a false alarm, as this
16035                  * successful one proves */
16036                 if (   posix_warnings
16037                     && av_tindex_skip_len_mg(posix_warnings) >= 0
16038                     && not_posix_region_end >= RExC_parse
16039                     && not_posix_region_end <= posix_class_end)
16040                 {
16041                     av_undef(posix_warnings);
16042                 }
16043
16044                 RExC_parse = posix_class_end;
16045             }
16046             else if (namedclass == OOB_NAMEDCLASS) {
16047                 not_posix_region_end = posix_class_end;
16048             }
16049             else {
16050                 namedclass = OOB_NAMEDCLASS;
16051             }
16052         }
16053         else if (   RExC_parse - 1 > not_posix_region_end
16054                  && MAYBE_POSIXCC(value))
16055         {
16056             (void) handle_possible_posix(
16057                         pRExC_state,
16058                         RExC_parse - 1,  /* -1 because parse has already been
16059                                             advanced */
16060                         &not_posix_region_end,
16061                         do_posix_warnings ? &posix_warnings : NULL,
16062                         TRUE /* checking only */);
16063         }
16064         else if (value == '\\') {
16065             /* Is a backslash; get the code point of the char after it */
16066
16067             if (RExC_parse >= RExC_end) {
16068                 vFAIL("Unmatched [");
16069             }
16070
16071             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16072                 value = utf8n_to_uvchr((U8*)RExC_parse,
16073                                    RExC_end - RExC_parse,
16074                                    &numlen, UTF8_ALLOW_DEFAULT);
16075                 RExC_parse += numlen;
16076             }
16077             else
16078                 value = UCHARAT(RExC_parse++);
16079
16080             /* Some compilers cannot handle switching on 64-bit integer
16081              * values, therefore value cannot be an UV.  Yes, this will
16082              * be a problem later if we want switch on Unicode.
16083              * A similar issue a little bit later when switching on
16084              * namedclass. --jhi */
16085
16086             /* If the \ is escaping white space when white space is being
16087              * skipped, it means that that white space is wanted literally, and
16088              * is already in 'value'.  Otherwise, need to translate the escape
16089              * into what it signifies. */
16090             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16091
16092             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16093             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16094             case 's':   namedclass = ANYOF_SPACE;       break;
16095             case 'S':   namedclass = ANYOF_NSPACE;      break;
16096             case 'd':   namedclass = ANYOF_DIGIT;       break;
16097             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16098             case 'v':   namedclass = ANYOF_VERTWS;      break;
16099             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16100             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16101             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16102             case 'N':  /* Handle \N{NAME} in class */
16103                 {
16104                     const char * const backslash_N_beg = RExC_parse - 2;
16105                     int cp_count;
16106
16107                     if (! grok_bslash_N(pRExC_state,
16108                                         NULL,      /* No regnode */
16109                                         &value,    /* Yes single value */
16110                                         &cp_count, /* Multiple code pt count */
16111                                         flagp,
16112                                         strict,
16113                                         depth)
16114                     ) {
16115
16116                         if (*flagp & NEED_UTF8)
16117                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16118                         if (*flagp & RESTART_PASS1)
16119                             return NULL;
16120
16121                         if (cp_count < 0) {
16122                             vFAIL("\\N in a character class must be a named character: \\N{...}");
16123                         }
16124                         else if (cp_count == 0) {
16125                             if (PASS2) {
16126                                 ckWARNreg(RExC_parse,
16127                                         "Ignoring zero length \\N{} in character class");
16128                             }
16129                         }
16130                         else { /* cp_count > 1 */
16131                             if (! RExC_in_multi_char_class) {
16132                                 if (invert || range || *RExC_parse == '-') {
16133                                     if (strict) {
16134                                         RExC_parse--;
16135                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
16136                                     }
16137                                     else if (PASS2) {
16138                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
16139                                     }
16140                                     break; /* <value> contains the first code
16141                                               point. Drop out of the switch to
16142                                               process it */
16143                                 }
16144                                 else {
16145                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
16146                                                  RExC_parse - backslash_N_beg);
16147                                     multi_char_matches
16148                                         = add_multi_match(multi_char_matches,
16149                                                           multi_char_N,
16150                                                           cp_count);
16151                                 }
16152                             }
16153                         } /* End of cp_count != 1 */
16154
16155                         /* This element should not be processed further in this
16156                          * class */
16157                         element_count--;
16158                         value = save_value;
16159                         prevvalue = save_prevvalue;
16160                         continue;   /* Back to top of loop to get next char */
16161                     }
16162
16163                     /* Here, is a single code point, and <value> contains it */
16164                     unicode_range = TRUE;   /* \N{} are Unicode */
16165                 }
16166                 break;
16167             case 'p':
16168             case 'P':
16169                 {
16170                 char *e;
16171
16172                 /* We will handle any undefined properties ourselves */
16173                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
16174                                        /* And we actually would prefer to get
16175                                         * the straight inversion list of the
16176                                         * swash, since we will be accessing it
16177                                         * anyway, to save a little time */
16178                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
16179
16180                 if (RExC_parse >= RExC_end)
16181                     vFAIL2("Empty \\%c", (U8)value);
16182                 if (*RExC_parse == '{') {
16183                     const U8 c = (U8)value;
16184                     e = strchr(RExC_parse, '}');
16185                     if (!e) {
16186                         RExC_parse++;
16187                         vFAIL2("Missing right brace on \\%c{}", c);
16188                     }
16189
16190                     RExC_parse++;
16191                     while (isSPACE(*RExC_parse)) {
16192                          RExC_parse++;
16193                     }
16194
16195                     if (UCHARAT(RExC_parse) == '^') {
16196
16197                         /* toggle.  (The rhs xor gets the single bit that
16198                          * differs between P and p; the other xor inverts just
16199                          * that bit) */
16200                         value ^= 'P' ^ 'p';
16201
16202                         RExC_parse++;
16203                         while (isSPACE(*RExC_parse)) {
16204                             RExC_parse++;
16205                         }
16206                     }
16207
16208                     if (e == RExC_parse)
16209                         vFAIL2("Empty \\%c{}", c);
16210
16211                     n = e - RExC_parse;
16212                     while (isSPACE(*(RExC_parse + n - 1)))
16213                         n--;
16214                 }   /* The \p isn't immediately followed by a '{' */
16215                 else if (! isALPHA(*RExC_parse)) {
16216                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16217                     vFAIL2("Character following \\%c must be '{' or a "
16218                            "single-character Unicode property name",
16219                            (U8) value);
16220                 }
16221                 else {
16222                     e = RExC_parse;
16223                     n = 1;
16224                 }
16225                 if (!SIZE_ONLY) {
16226                     SV* invlist;
16227                     char* name;
16228                     char* base_name;    /* name after any packages are stripped */
16229                     char* lookup_name = NULL;
16230                     const char * const colon_colon = "::";
16231
16232                     /* Try to get the definition of the property into
16233                      * <invlist>.  If /i is in effect, the effective property
16234                      * will have its name be <__NAME_i>.  The design is
16235                      * discussed in commit
16236                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
16237                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
16238                     SAVEFREEPV(name);
16239                     if (FOLD) {
16240                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
16241
16242                         /* The function call just below that uses this can fail
16243                          * to return, leaking memory if we don't do this */
16244                         SAVEFREEPV(lookup_name);
16245                     }
16246
16247                     /* Look up the property name, and get its swash and
16248                      * inversion list, if the property is found  */
16249                     SvREFCNT_dec(swash); /* Free any left-overs */
16250                     swash = _core_swash_init("utf8",
16251                                              (lookup_name)
16252                                               ? lookup_name
16253                                               : name,
16254                                              &PL_sv_undef,
16255                                              1, /* binary */
16256                                              0, /* not tr/// */
16257                                              NULL, /* No inversion list */
16258                                              &swash_init_flags
16259                                             );
16260                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
16261                         HV* curpkg = (IN_PERL_COMPILETIME)
16262                                       ? PL_curstash
16263                                       : CopSTASH(PL_curcop);
16264                         UV final_n = n;
16265                         bool has_pkg;
16266
16267                         if (swash) {    /* Got a swash but no inversion list.
16268                                            Something is likely wrong that will
16269                                            be sorted-out later */
16270                             SvREFCNT_dec_NN(swash);
16271                             swash = NULL;
16272                         }
16273
16274                         /* Here didn't find it.  It could be a an error (like a
16275                          * typo) in specifying a Unicode property, or it could
16276                          * be a user-defined property that will be available at
16277                          * run-time.  The names of these must begin with 'In'
16278                          * or 'Is' (after any packages are stripped off).  So
16279                          * if not one of those, or if we accept only
16280                          * compile-time properties, is an error; otherwise add
16281                          * it to the list for run-time look up. */
16282                         if ((base_name = rninstr(name, name + n,
16283                                                  colon_colon, colon_colon + 2)))
16284                         { /* Has ::.  We know this must be a user-defined
16285                              property */
16286                             base_name += 2;
16287                             final_n -= base_name - name;
16288                             has_pkg = TRUE;
16289                         }
16290                         else {
16291                             base_name = name;
16292                             has_pkg = FALSE;
16293                         }
16294
16295                         if (   final_n < 3
16296                             || base_name[0] != 'I'
16297                             || (base_name[1] != 's' && base_name[1] != 'n')
16298                             || ret_invlist)
16299                         {
16300                             const char * const msg
16301                                 = (has_pkg)
16302                                   ? "Illegal user-defined property name"
16303                                   : "Can't find Unicode property definition";
16304                             RExC_parse = e + 1;
16305
16306                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16307                             vFAIL3utf8f("%s \"%" UTF8f "\"",
16308                                 msg, UTF8fARG(UTF, n, name));
16309                         }
16310
16311                         /* If the property name doesn't already have a package
16312                          * name, add the current one to it so that it can be
16313                          * referred to outside it. [perl #121777] */
16314                         if (! has_pkg && curpkg) {
16315                             char* pkgname = HvNAME(curpkg);
16316                             if (strNE(pkgname, "main")) {
16317                                 char* full_name = Perl_form(aTHX_
16318                                                             "%s::%s",
16319                                                             pkgname,
16320                                                             name);
16321                                 n = strlen(full_name);
16322                                 name = savepvn(full_name, n);
16323                                 SAVEFREEPV(name);
16324                             }
16325                         }
16326                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
16327                                         (value == 'p' ? '+' : '!'),
16328                                         (FOLD) ? "__" : "",
16329                                         UTF8fARG(UTF, n, name),
16330                                         (FOLD) ? "_i" : "");
16331                         has_user_defined_property = TRUE;
16332                         optimizable = FALSE;    /* Will have to leave this an
16333                                                    ANYOF node */
16334
16335                         /* We don't know yet what this matches, so have to flag
16336                          * it */
16337                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16338                     }
16339                     else {
16340
16341                         /* Here, did get the swash and its inversion list.  If
16342                          * the swash is from a user-defined property, then this
16343                          * whole character class should be regarded as such */
16344                         if (swash_init_flags
16345                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16346                         {
16347                             has_user_defined_property = TRUE;
16348                         }
16349                         else if
16350                             /* We warn on matching an above-Unicode code point
16351                              * if the match would return true, except don't
16352                              * warn for \p{All}, which has exactly one element
16353                              * = 0 */
16354                             (_invlist_contains_cp(invlist, 0x110000)
16355                                 && (! (_invlist_len(invlist) == 1
16356                                        && *invlist_array(invlist) == 0)))
16357                         {
16358                             warn_super = TRUE;
16359                         }
16360
16361
16362                         /* Invert if asking for the complement */
16363                         if (value == 'P') {
16364                             _invlist_union_complement_2nd(properties,
16365                                                           invlist,
16366                                                           &properties);
16367
16368                             /* The swash can't be used as-is, because we've
16369                              * inverted things; delay removing it to here after
16370                              * have copied its invlist above */
16371                             SvREFCNT_dec_NN(swash);
16372                             swash = NULL;
16373                         }
16374                         else {
16375                             _invlist_union(properties, invlist, &properties);
16376                         }
16377                     }
16378                 }
16379                 RExC_parse = e + 1;
16380                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16381                                                 named */
16382
16383                 /* \p means they want Unicode semantics */
16384                 REQUIRE_UNI_RULES(flagp, NULL);
16385                 }
16386                 break;
16387             case 'n':   value = '\n';                   break;
16388             case 'r':   value = '\r';                   break;
16389             case 't':   value = '\t';                   break;
16390             case 'f':   value = '\f';                   break;
16391             case 'b':   value = '\b';                   break;
16392             case 'e':   value = ESC_NATIVE;             break;
16393             case 'a':   value = '\a';                   break;
16394             case 'o':
16395                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16396                 {
16397                     const char* error_msg;
16398                     bool valid = grok_bslash_o(&RExC_parse,
16399                                                &value,
16400                                                &error_msg,
16401                                                PASS2,   /* warnings only in
16402                                                            pass 2 */
16403                                                strict,
16404                                                silence_non_portable,
16405                                                UTF);
16406                     if (! valid) {
16407                         vFAIL(error_msg);
16408                     }
16409                 }
16410                 non_portable_endpoint++;
16411                 break;
16412             case 'x':
16413                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16414                 {
16415                     const char* error_msg;
16416                     bool valid = grok_bslash_x(&RExC_parse,
16417                                                &value,
16418                                                &error_msg,
16419                                                PASS2, /* Output warnings */
16420                                                strict,
16421                                                silence_non_portable,
16422                                                UTF);
16423                     if (! valid) {
16424                         vFAIL(error_msg);
16425                     }
16426                 }
16427                 non_portable_endpoint++;
16428                 break;
16429             case 'c':
16430                 value = grok_bslash_c(*RExC_parse++, PASS2);
16431                 non_portable_endpoint++;
16432                 break;
16433             case '0': case '1': case '2': case '3': case '4':
16434             case '5': case '6': case '7':
16435                 {
16436                     /* Take 1-3 octal digits */
16437                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16438                     numlen = (strict) ? 4 : 3;
16439                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16440                     RExC_parse += numlen;
16441                     if (numlen != 3) {
16442                         if (strict) {
16443                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16444                             vFAIL("Need exactly 3 octal digits");
16445                         }
16446                         else if (! SIZE_ONLY /* like \08, \178 */
16447                                  && numlen < 3
16448                                  && RExC_parse < RExC_end
16449                                  && isDIGIT(*RExC_parse)
16450                                  && ckWARN(WARN_REGEXP))
16451                         {
16452                             SAVEFREESV(RExC_rx_sv);
16453                             reg_warn_non_literal_string(
16454                                  RExC_parse + 1,
16455                                  form_short_octal_warning(RExC_parse, numlen));
16456                             (void)ReREFCNT_inc(RExC_rx_sv);
16457                         }
16458                     }
16459                     non_portable_endpoint++;
16460                     break;
16461                 }
16462             default:
16463                 /* Allow \_ to not give an error */
16464                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16465                     if (strict) {
16466                         vFAIL2("Unrecognized escape \\%c in character class",
16467                                (int)value);
16468                     }
16469                     else {
16470                         SAVEFREESV(RExC_rx_sv);
16471                         ckWARN2reg(RExC_parse,
16472                             "Unrecognized escape \\%c in character class passed through",
16473                             (int)value);
16474                         (void)ReREFCNT_inc(RExC_rx_sv);
16475                     }
16476                 }
16477                 break;
16478             }   /* End of switch on char following backslash */
16479         } /* end of handling backslash escape sequences */
16480
16481         /* Here, we have the current token in 'value' */
16482
16483         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
16484             U8 classnum;
16485
16486             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
16487              * literal, as is the character that began the false range, i.e.
16488              * the 'a' in the examples */
16489             if (range) {
16490                 if (!SIZE_ONLY) {
16491                     const int w = (RExC_parse >= rangebegin)
16492                                   ? RExC_parse - rangebegin
16493                                   : 0;
16494                     if (strict) {
16495                         vFAIL2utf8f(
16496                             "False [] range \"%" UTF8f "\"",
16497                             UTF8fARG(UTF, w, rangebegin));
16498                     }
16499                     else {
16500                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
16501                         ckWARN2reg(RExC_parse,
16502                             "False [] range \"%" UTF8f "\"",
16503                             UTF8fARG(UTF, w, rangebegin));
16504                         (void)ReREFCNT_inc(RExC_rx_sv);
16505                         cp_list = add_cp_to_invlist(cp_list, '-');
16506                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
16507                                                              prevvalue);
16508                     }
16509                 }
16510
16511                 range = 0; /* this was not a true range */
16512                 element_count += 2; /* So counts for three values */
16513             }
16514
16515             classnum = namedclass_to_classnum(namedclass);
16516
16517             if (LOC && namedclass < ANYOF_POSIXL_MAX
16518 #ifndef HAS_ISASCII
16519                 && classnum != _CC_ASCII
16520 #endif
16521             ) {
16522                 /* What the Posix classes (like \w, [:space:]) match in locale
16523                  * isn't knowable under locale until actual match time.  Room
16524                  * must be reserved (one time per outer bracketed class) to
16525                  * store such classes.  The space will contain a bit for each
16526                  * named class that is to be matched against.  This isn't
16527                  * needed for \p{} and pseudo-classes, as they are not affected
16528                  * by locale, and hence are dealt with separately */
16529                 if (! need_class) {
16530                     need_class = 1;
16531                     if (SIZE_ONLY) {
16532                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16533                     }
16534                     else {
16535                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16536                     }
16537                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
16538                     ANYOF_POSIXL_ZERO(ret);
16539
16540                     /* We can't change this into some other type of node
16541                      * (unless this is the only element, in which case there
16542                      * are nodes that mean exactly this) as has runtime
16543                      * dependencies */
16544                     optimizable = FALSE;
16545                 }
16546
16547                 /* Coverity thinks it is possible for this to be negative; both
16548                  * jhi and khw think it's not, but be safer */
16549                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16550                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
16551
16552                 /* See if it already matches the complement of this POSIX
16553                  * class */
16554                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16555                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
16556                                                             ? -1
16557                                                             : 1)))
16558                 {
16559                     posixl_matches_all = TRUE;
16560                     break;  /* No need to continue.  Since it matches both
16561                                e.g., \w and \W, it matches everything, and the
16562                                bracketed class can be optimized into qr/./s */
16563                 }
16564
16565                 /* Add this class to those that should be checked at runtime */
16566                 ANYOF_POSIXL_SET(ret, namedclass);
16567
16568                 /* The above-Latin1 characters are not subject to locale rules.
16569                  * Just add them, in the second pass, to the
16570                  * unconditionally-matched list */
16571                 if (! SIZE_ONLY) {
16572                     SV* scratch_list = NULL;
16573
16574                     /* Get the list of the above-Latin1 code points this
16575                      * matches */
16576                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
16577                                           PL_XPosix_ptrs[classnum],
16578
16579                                           /* Odd numbers are complements, like
16580                                            * NDIGIT, NASCII, ... */
16581                                           namedclass % 2 != 0,
16582                                           &scratch_list);
16583                     /* Checking if 'cp_list' is NULL first saves an extra
16584                      * clone.  Its reference count will be decremented at the
16585                      * next union, etc, or if this is the only instance, at the
16586                      * end of the routine */
16587                     if (! cp_list) {
16588                         cp_list = scratch_list;
16589                     }
16590                     else {
16591                         _invlist_union(cp_list, scratch_list, &cp_list);
16592                         SvREFCNT_dec_NN(scratch_list);
16593                     }
16594                     continue;   /* Go get next character */
16595                 }
16596             }
16597             else if (! SIZE_ONLY) {
16598
16599                 /* Here, not in pass1 (in that pass we skip calculating the
16600                  * contents of this class), and is not /l, or is a POSIX class
16601                  * for which /l doesn't matter (or is a Unicode property, which
16602                  * is skipped here). */
16603                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
16604                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
16605
16606                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
16607                          * nor /l make a difference in what these match,
16608                          * therefore we just add what they match to cp_list. */
16609                         if (classnum != _CC_VERTSPACE) {
16610                             assert(   namedclass == ANYOF_HORIZWS
16611                                    || namedclass == ANYOF_NHORIZWS);
16612
16613                             /* It turns out that \h is just a synonym for
16614                              * XPosixBlank */
16615                             classnum = _CC_BLANK;
16616                         }
16617
16618                         _invlist_union_maybe_complement_2nd(
16619                                 cp_list,
16620                                 PL_XPosix_ptrs[classnum],
16621                                 namedclass % 2 != 0,    /* Complement if odd
16622                                                           (NHORIZWS, NVERTWS)
16623                                                         */
16624                                 &cp_list);
16625                     }
16626                 }
16627                 else if (  UNI_SEMANTICS
16628                         || classnum == _CC_ASCII
16629                         || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
16630                                                   || classnum == _CC_XDIGIT)))
16631                 {
16632                     /* We usually have to worry about /d and /a affecting what
16633                      * POSIX classes match, with special code needed for /d
16634                      * because we won't know until runtime what all matches.
16635                      * But there is no extra work needed under /u, and
16636                      * [:ascii:] is unaffected by /a and /d; and :digit: and
16637                      * :xdigit: don't have runtime differences under /d.  So we
16638                      * can special case these, and avoid some extra work below,
16639                      * and at runtime. */
16640                     _invlist_union_maybe_complement_2nd(
16641                                                      simple_posixes,
16642                                                      PL_XPosix_ptrs[classnum],
16643                                                      namedclass % 2 != 0,
16644                                                      &simple_posixes);
16645                 }
16646                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
16647                            complement and use nposixes */
16648                     SV** posixes_ptr = namedclass % 2 == 0
16649                                        ? &posixes
16650                                        : &nposixes;
16651                     _invlist_union_maybe_complement_2nd(
16652                                                      *posixes_ptr,
16653                                                      PL_XPosix_ptrs[classnum],
16654                                                      namedclass % 2 != 0,
16655                                                      posixes_ptr);
16656                 }
16657             }
16658         } /* end of namedclass \blah */
16659
16660         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16661
16662         /* If 'range' is set, 'value' is the ending of a range--check its
16663          * validity.  (If value isn't a single code point in the case of a
16664          * range, we should have figured that out above in the code that
16665          * catches false ranges).  Later, we will handle each individual code
16666          * point in the range.  If 'range' isn't set, this could be the
16667          * beginning of a range, so check for that by looking ahead to see if
16668          * the next real character to be processed is the range indicator--the
16669          * minus sign */
16670
16671         if (range) {
16672 #ifdef EBCDIC
16673             /* For unicode ranges, we have to test that the Unicode as opposed
16674              * to the native values are not decreasing.  (Above 255, there is
16675              * no difference between native and Unicode) */
16676             if (unicode_range && prevvalue < 255 && value < 255) {
16677                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
16678                     goto backwards_range;
16679                 }
16680             }
16681             else
16682 #endif
16683             if (prevvalue > value) /* b-a */ {
16684                 int w;
16685 #ifdef EBCDIC
16686               backwards_range:
16687 #endif
16688                 w = RExC_parse - rangebegin;
16689                 vFAIL2utf8f(
16690                     "Invalid [] range \"%" UTF8f "\"",
16691                     UTF8fARG(UTF, w, rangebegin));
16692                 NOT_REACHED; /* NOTREACHED */
16693             }
16694         }
16695         else {
16696             prevvalue = value; /* save the beginning of the potential range */
16697             if (! stop_at_1     /* Can't be a range if parsing just one thing */
16698                 && *RExC_parse == '-')
16699             {
16700                 char* next_char_ptr = RExC_parse + 1;
16701
16702                 /* Get the next real char after the '-' */
16703                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
16704
16705                 /* If the '-' is at the end of the class (just before the ']',
16706                  * it is a literal minus; otherwise it is a range */
16707                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
16708                     RExC_parse = next_char_ptr;
16709
16710                     /* a bad range like \w-, [:word:]- ? */
16711                     if (namedclass > OOB_NAMEDCLASS) {
16712                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
16713                             const int w = RExC_parse >= rangebegin
16714                                           ?  RExC_parse - rangebegin
16715                                           : 0;
16716                             if (strict) {
16717                                 vFAIL4("False [] range \"%*.*s\"",
16718                                     w, w, rangebegin);
16719                             }
16720                             else if (PASS2) {
16721                                 vWARN4(RExC_parse,
16722                                     "False [] range \"%*.*s\"",
16723                                     w, w, rangebegin);
16724                             }
16725                         }
16726                         if (!SIZE_ONLY) {
16727                             cp_list = add_cp_to_invlist(cp_list, '-');
16728                         }
16729                         element_count++;
16730                     } else
16731                         range = 1;      /* yeah, it's a range! */
16732                     continue;   /* but do it the next time */
16733                 }
16734             }
16735         }
16736
16737         if (namedclass > OOB_NAMEDCLASS) {
16738             continue;
16739         }
16740
16741         /* Here, we have a single value this time through the loop, and
16742          * <prevvalue> is the beginning of the range, if any; or <value> if
16743          * not. */
16744
16745         /* non-Latin1 code point implies unicode semantics.  Must be set in
16746          * pass1 so is there for the whole of pass 2 */
16747         if (value > 255) {
16748             REQUIRE_UNI_RULES(flagp, NULL);
16749         }
16750
16751         /* Ready to process either the single value, or the completed range.
16752          * For single-valued non-inverted ranges, we consider the possibility
16753          * of multi-char folds.  (We made a conscious decision to not do this
16754          * for the other cases because it can often lead to non-intuitive
16755          * results.  For example, you have the peculiar case that:
16756          *  "s s" =~ /^[^\xDF]+$/i => Y
16757          *  "ss"  =~ /^[^\xDF]+$/i => N
16758          *
16759          * See [perl #89750] */
16760         if (FOLD && allow_multi_folds && value == prevvalue) {
16761             if (value == LATIN_SMALL_LETTER_SHARP_S
16762                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
16763                                                         value)))
16764             {
16765                 /* Here <value> is indeed a multi-char fold.  Get what it is */
16766
16767                 U8 foldbuf[UTF8_MAXBYTES_CASE];
16768                 STRLEN foldlen;
16769
16770                 UV folded = _to_uni_fold_flags(
16771                                 value,
16772                                 foldbuf,
16773                                 &foldlen,
16774                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
16775                                                    ? FOLD_FLAGS_NOMIX_ASCII
16776                                                    : 0)
16777                                 );
16778
16779                 /* Here, <folded> should be the first character of the
16780                  * multi-char fold of <value>, with <foldbuf> containing the
16781                  * whole thing.  But, if this fold is not allowed (because of
16782                  * the flags), <fold> will be the same as <value>, and should
16783                  * be processed like any other character, so skip the special
16784                  * handling */
16785                 if (folded != value) {
16786
16787                     /* Skip if we are recursed, currently parsing the class
16788                      * again.  Otherwise add this character to the list of
16789                      * multi-char folds. */
16790                     if (! RExC_in_multi_char_class) {
16791                         STRLEN cp_count = utf8_length(foldbuf,
16792                                                       foldbuf + foldlen);
16793                         SV* multi_fold = sv_2mortal(newSVpvs(""));
16794
16795                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
16796
16797                         multi_char_matches
16798                                         = add_multi_match(multi_char_matches,
16799                                                           multi_fold,
16800                                                           cp_count);
16801
16802                     }
16803
16804                     /* This element should not be processed further in this
16805                      * class */
16806                     element_count--;
16807                     value = save_value;
16808                     prevvalue = save_prevvalue;
16809                     continue;
16810                 }
16811             }
16812         }
16813
16814         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
16815             if (range) {
16816
16817                 /* If the range starts above 255, everything is portable and
16818                  * likely to be so for any forseeable character set, so don't
16819                  * warn. */
16820                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
16821                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
16822                 }
16823                 else if (prevvalue != value) {
16824
16825                     /* Under strict, ranges that stop and/or end in an ASCII
16826                      * printable should have each end point be a portable value
16827                      * for it (preferably like 'A', but we don't warn if it is
16828                      * a (portable) Unicode name or code point), and the range
16829                      * must be be all digits or all letters of the same case.
16830                      * Otherwise, the range is non-portable and unclear as to
16831                      * what it contains */
16832                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
16833                         && (          non_portable_endpoint
16834                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
16835                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
16836                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
16837                     ))) {
16838                         vWARN(RExC_parse, "Ranges of ASCII printables should"
16839                                           " be some subset of \"0-9\","
16840                                           " \"A-Z\", or \"a-z\"");
16841                     }
16842                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
16843                         SSize_t index_start;
16844                         SSize_t index_final;
16845
16846                         /* But the nature of Unicode and languages mean we
16847                          * can't do the same checks for above-ASCII ranges,
16848                          * except in the case of digit ones.  These should
16849                          * contain only digits from the same group of 10.  The
16850                          * ASCII case is handled just above.  0x660 is the
16851                          * first digit character beyond ASCII.  Hence here, the
16852                          * range could be a range of digits.  First some
16853                          * unlikely special cases.  Grandfather in that a range
16854                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
16855                          * if its starting value is one of the 10 digits prior
16856                          * to it.  This is because it is an alternate way of
16857                          * writing 19D1, and some people may expect it to be in
16858                          * that group.  But it is bad, because it won't give
16859                          * the expected results.  In Unicode 5.2 it was
16860                          * considered to be in that group (of 11, hence), but
16861                          * this was fixed in the next version */
16862
16863                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
16864                             goto warn_bad_digit_range;
16865                         }
16866                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
16867                                           &&     value <= 0x1D7FF))
16868                         {
16869                             /* This is the only other case currently in Unicode
16870                              * where the algorithm below fails.  The code
16871                              * points just above are the end points of a single
16872                              * range containing only decimal digits.  It is 5
16873                              * different series of 0-9.  All other ranges of
16874                              * digits currently in Unicode are just a single
16875                              * series.  (And mktables will notify us if a later
16876                              * Unicode version breaks this.)
16877                              *
16878                              * If the range being checked is at most 9 long,
16879                              * and the digit values represented are in
16880                              * numerical order, they are from the same series.
16881                              * */
16882                             if (         value - prevvalue > 9
16883                                 ||    (((    value - 0x1D7CE) % 10)
16884                                      <= (prevvalue - 0x1D7CE) % 10))
16885                             {
16886                                 goto warn_bad_digit_range;
16887                             }
16888                         }
16889                         else {
16890
16891                             /* For all other ranges of digits in Unicode, the
16892                              * algorithm is just to check if both end points
16893                              * are in the same series, which is the same range.
16894                              * */
16895                             index_start = _invlist_search(
16896                                                     PL_XPosix_ptrs[_CC_DIGIT],
16897                                                     prevvalue);
16898
16899                             /* Warn if the range starts and ends with a digit,
16900                              * and they are not in the same group of 10. */
16901                             if (   index_start >= 0
16902                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
16903                                 && (index_final =
16904                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16905                                                     value)) != index_start
16906                                 && index_final >= 0
16907                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
16908                             {
16909                               warn_bad_digit_range:
16910                                 vWARN(RExC_parse, "Ranges of digits should be"
16911                                                   " from the same group of"
16912                                                   " 10");
16913                             }
16914                         }
16915                     }
16916                 }
16917             }
16918             if ((! range || prevvalue == value) && non_portable_endpoint) {
16919                 if (isPRINT_A(value)) {
16920                     char literal[3];
16921                     unsigned d = 0;
16922                     if (isBACKSLASHED_PUNCT(value)) {
16923                         literal[d++] = '\\';
16924                     }
16925                     literal[d++] = (char) value;
16926                     literal[d++] = '\0';
16927
16928                     vWARN4(RExC_parse,
16929                            "\"%.*s\" is more clearly written simply as \"%s\"",
16930                            (int) (RExC_parse - rangebegin),
16931                            rangebegin,
16932                            literal
16933                         );
16934                 }
16935                 else if isMNEMONIC_CNTRL(value) {
16936                     vWARN4(RExC_parse,
16937                            "\"%.*s\" is more clearly written simply as \"%s\"",
16938                            (int) (RExC_parse - rangebegin),
16939                            rangebegin,
16940                            cntrl_to_mnemonic((U8) value)
16941                         );
16942                 }
16943             }
16944         }
16945
16946         /* Deal with this element of the class */
16947         if (! SIZE_ONLY) {
16948
16949 #ifndef EBCDIC
16950             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16951                                                      prevvalue, value);
16952 #else
16953             /* On non-ASCII platforms, for ranges that span all of 0..255, and
16954              * ones that don't require special handling, we can just add the
16955              * range like we do for ASCII platforms */
16956             if ((UNLIKELY(prevvalue == 0) && value >= 255)
16957                 || ! (prevvalue < 256
16958                       && (unicode_range
16959                           || (! non_portable_endpoint
16960                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
16961                                   || (isUPPER_A(prevvalue)
16962                                       && isUPPER_A(value)))))))
16963             {
16964                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16965                                                          prevvalue, value);
16966             }
16967             else {
16968                 /* Here, requires special handling.  This can be because it is
16969                  * a range whose code points are considered to be Unicode, and
16970                  * so must be individually translated into native, or because
16971                  * its a subrange of 'A-Z' or 'a-z' which each aren't
16972                  * contiguous in EBCDIC, but we have defined them to include
16973                  * only the "expected" upper or lower case ASCII alphabetics.
16974                  * Subranges above 255 are the same in native and Unicode, so
16975                  * can be added as a range */
16976                 U8 start = NATIVE_TO_LATIN1(prevvalue);
16977                 unsigned j;
16978                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
16979                 for (j = start; j <= end; j++) {
16980                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
16981                 }
16982                 if (value > 255) {
16983                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16984                                                              256, value);
16985                 }
16986             }
16987 #endif
16988         }
16989
16990         range = 0; /* this range (if it was one) is done now */
16991     } /* End of loop through all the text within the brackets */
16992
16993
16994     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
16995         output_or_return_posix_warnings(pRExC_state, posix_warnings,
16996                                         return_posix_warnings);
16997     }
16998
16999     /* If anything in the class expands to more than one character, we have to
17000      * deal with them by building up a substitute parse string, and recursively
17001      * calling reg() on it, instead of proceeding */
17002     if (multi_char_matches) {
17003         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
17004         I32 cp_count;
17005         STRLEN len;
17006         char *save_end = RExC_end;
17007         char *save_parse = RExC_parse;
17008         char *save_start = RExC_start;
17009         STRLEN prefix_end = 0;      /* We copy the character class after a
17010                                        prefix supplied here.  This is the size
17011                                        + 1 of that prefix */
17012         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
17013                                        a "|" */
17014         I32 reg_flags;
17015
17016         assert(! invert);
17017         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
17018
17019 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
17020            because too confusing */
17021         if (invert) {
17022             sv_catpv(substitute_parse, "(?:");
17023         }
17024 #endif
17025
17026         /* Look at the longest folds first */
17027         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
17028                         cp_count > 0;
17029                         cp_count--)
17030         {
17031
17032             if (av_exists(multi_char_matches, cp_count)) {
17033                 AV** this_array_ptr;
17034                 SV* this_sequence;
17035
17036                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
17037                                                  cp_count, FALSE);
17038                 while ((this_sequence = av_pop(*this_array_ptr)) !=
17039                                                                 &PL_sv_undef)
17040                 {
17041                     if (! first_time) {
17042                         sv_catpv(substitute_parse, "|");
17043                     }
17044                     first_time = FALSE;
17045
17046                     sv_catpv(substitute_parse, SvPVX(this_sequence));
17047                 }
17048             }
17049         }
17050
17051         /* If the character class contains anything else besides these
17052          * multi-character folds, have to include it in recursive parsing */
17053         if (element_count) {
17054             sv_catpv(substitute_parse, "|[");
17055             prefix_end = SvCUR(substitute_parse);
17056             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17057
17058             /* Put in a closing ']' only if not going off the end, as otherwise
17059              * we are adding something that really isn't there */
17060             if (RExC_parse < RExC_end) {
17061                 sv_catpv(substitute_parse, "]");
17062             }
17063         }
17064
17065         sv_catpv(substitute_parse, ")");
17066 #if 0
17067         if (invert) {
17068             /* This is a way to get the parse to skip forward a whole named
17069              * sequence instead of matching the 2nd character when it fails the
17070              * first */
17071             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17072         }
17073 #endif
17074
17075         /* Set up the data structure so that any errors will be properly
17076          * reported.  See the comments at the definition of
17077          * REPORT_LOCATION_ARGS for details */
17078         RExC_precomp_adj = orig_parse - RExC_precomp;
17079         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
17080         RExC_adjusted_start = RExC_start + prefix_end;
17081         RExC_end = RExC_parse + len;
17082         RExC_in_multi_char_class = 1;
17083         RExC_emit = (regnode *)orig_emit;
17084
17085         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17086
17087         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
17088
17089         /* And restore so can parse the rest of the pattern */
17090         RExC_parse = save_parse;
17091         RExC_start = RExC_adjusted_start = save_start;
17092         RExC_precomp_adj = 0;
17093         RExC_end = save_end;
17094         RExC_in_multi_char_class = 0;
17095         SvREFCNT_dec_NN(multi_char_matches);
17096         return ret;
17097     }
17098
17099     /* Here, we've gone through the entire class and dealt with multi-char
17100      * folds.  We are now in a position that we can do some checks to see if we
17101      * can optimize this ANYOF node into a simpler one, even in Pass 1.
17102      * Currently we only do two checks:
17103      * 1) is in the unlikely event that the user has specified both, eg. \w and
17104      *    \W under /l, then the class matches everything.  (This optimization
17105      *    is done only to make the optimizer code run later work.)
17106      * 2) if the character class contains only a single element (including a
17107      *    single range), we see if there is an equivalent node for it.
17108      * Other checks are possible */
17109     if (   optimizable
17110         && ! ret_invlist   /* Can't optimize if returning the constructed
17111                               inversion list */
17112         && (UNLIKELY(posixl_matches_all) || element_count == 1))
17113     {
17114         U8 op = END;
17115         U8 arg = 0;
17116
17117         if (UNLIKELY(posixl_matches_all)) {
17118             op = SANY;
17119         }
17120         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
17121                                                    class, like \w or [:digit:]
17122                                                    or \p{foo} */
17123
17124             /* All named classes are mapped into POSIXish nodes, with its FLAG
17125              * argument giving which class it is */
17126             switch ((I32)namedclass) {
17127                 case ANYOF_UNIPROP:
17128                     break;
17129
17130                 /* These don't depend on the charset modifiers.  They always
17131                  * match under /u rules */
17132                 case ANYOF_NHORIZWS:
17133                 case ANYOF_HORIZWS:
17134                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
17135                     /* FALLTHROUGH */
17136
17137                 case ANYOF_NVERTWS:
17138                 case ANYOF_VERTWS:
17139                     op = POSIXU;
17140                     goto join_posix;
17141
17142                 /* The actual POSIXish node for all the rest depends on the
17143                  * charset modifier.  The ones in the first set depend only on
17144                  * ASCII or, if available on this platform, also locale */
17145                 case ANYOF_ASCII:
17146                 case ANYOF_NASCII:
17147 #ifdef HAS_ISASCII
17148                     op = (LOC) ? POSIXL : POSIXA;
17149 #else
17150                     op = POSIXA;
17151 #endif
17152                     goto join_posix;
17153
17154                 /* The following don't have any matches in the upper Latin1
17155                  * range, hence /d is equivalent to /u for them.  Making it /u
17156                  * saves some branches at runtime */
17157                 case ANYOF_DIGIT:
17158                 case ANYOF_NDIGIT:
17159                 case ANYOF_XDIGIT:
17160                 case ANYOF_NXDIGIT:
17161                     if (! DEPENDS_SEMANTICS) {
17162                         goto treat_as_default;
17163                     }
17164
17165                     op = POSIXU;
17166                     goto join_posix;
17167
17168                 /* The following change to CASED under /i */
17169                 case ANYOF_LOWER:
17170                 case ANYOF_NLOWER:
17171                 case ANYOF_UPPER:
17172                 case ANYOF_NUPPER:
17173                     if (FOLD) {
17174                         namedclass = ANYOF_CASED + (namedclass % 2);
17175                     }
17176                     /* FALLTHROUGH */
17177
17178                 /* The rest have more possibilities depending on the charset.
17179                  * We take advantage of the enum ordering of the charset
17180                  * modifiers to get the exact node type, */
17181                 default:
17182                   treat_as_default:
17183                     op = POSIXD + get_regex_charset(RExC_flags);
17184                     if (op > POSIXA) { /* /aa is same as /a */
17185                         op = POSIXA;
17186                     }
17187
17188                   join_posix:
17189                     /* The odd numbered ones are the complements of the
17190                      * next-lower even number one */
17191                     if (namedclass % 2 == 1) {
17192                         invert = ! invert;
17193                         namedclass--;
17194                     }
17195                     arg = namedclass_to_classnum(namedclass);
17196                     break;
17197             }
17198         }
17199         else if (value == prevvalue) {
17200
17201             /* Here, the class consists of just a single code point */
17202
17203             if (invert) {
17204                 if (! LOC && value == '\n') {
17205                     op = REG_ANY; /* Optimize [^\n] */
17206                     *flagp |= HASWIDTH|SIMPLE;
17207                     MARK_NAUGHTY(1);
17208                 }
17209             }
17210             else if (value < 256 || UTF) {
17211
17212                 /* Optimize a single value into an EXACTish node, but not if it
17213                  * would require converting the pattern to UTF-8. */
17214                 op = compute_EXACTish(pRExC_state);
17215             }
17216         } /* Otherwise is a range */
17217         else if (! LOC) {   /* locale could vary these */
17218             if (prevvalue == '0') {
17219                 if (value == '9') {
17220                     arg = _CC_DIGIT;
17221                     op = POSIXA;
17222                 }
17223             }
17224             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
17225                 /* We can optimize A-Z or a-z, but not if they could match
17226                  * something like the KELVIN SIGN under /i. */
17227                 if (prevvalue == 'A') {
17228                     if (value == 'Z'
17229 #ifdef EBCDIC
17230                         && ! non_portable_endpoint
17231 #endif
17232                     ) {
17233                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
17234                         op = POSIXA;
17235                     }
17236                 }
17237                 else if (prevvalue == 'a') {
17238                     if (value == 'z'
17239 #ifdef EBCDIC
17240                         && ! non_portable_endpoint
17241 #endif
17242                     ) {
17243                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
17244                         op = POSIXA;
17245                     }
17246                 }
17247             }
17248         }
17249
17250         /* Here, we have changed <op> away from its initial value iff we found
17251          * an optimization */
17252         if (op != END) {
17253
17254             /* Throw away this ANYOF regnode, and emit the calculated one,
17255              * which should correspond to the beginning, not current, state of
17256              * the parse */
17257             const char * cur_parse = RExC_parse;
17258             RExC_parse = (char *)orig_parse;
17259             if ( SIZE_ONLY) {
17260                 if (! LOC) {
17261
17262                     /* To get locale nodes to not use the full ANYOF size would
17263                      * require moving the code above that writes the portions
17264                      * of it that aren't in other nodes to after this point.
17265                      * e.g.  ANYOF_POSIXL_SET */
17266                     RExC_size = orig_size;
17267                 }
17268             }
17269             else {
17270                 RExC_emit = (regnode *)orig_emit;
17271                 if (PL_regkind[op] == POSIXD) {
17272                     if (op == POSIXL) {
17273                         RExC_contains_locale = 1;
17274                     }
17275                     if (invert) {
17276                         op += NPOSIXD - POSIXD;
17277                     }
17278                 }
17279             }
17280
17281             ret = reg_node(pRExC_state, op);
17282
17283             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17284                 if (! SIZE_ONLY) {
17285                     FLAGS(ret) = arg;
17286                 }
17287                 *flagp |= HASWIDTH|SIMPLE;
17288             }
17289             else if (PL_regkind[op] == EXACT) {
17290                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17291                                            TRUE /* downgradable to EXACT */
17292                                            );
17293             }
17294
17295             RExC_parse = (char *) cur_parse;
17296
17297             SvREFCNT_dec(posixes);
17298             SvREFCNT_dec(nposixes);
17299             SvREFCNT_dec(simple_posixes);
17300             SvREFCNT_dec(cp_list);
17301             SvREFCNT_dec(cp_foldable_list);
17302             return ret;
17303         }
17304     }
17305
17306     if (SIZE_ONLY)
17307         return ret;
17308     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17309
17310     /* If folding, we calculate all characters that could fold to or from the
17311      * ones already on the list */
17312     if (cp_foldable_list) {
17313         if (FOLD) {
17314             UV start, end;      /* End points of code point ranges */
17315
17316             SV* fold_intersection = NULL;
17317             SV** use_list;
17318
17319             /* Our calculated list will be for Unicode rules.  For locale
17320              * matching, we have to keep a separate list that is consulted at
17321              * runtime only when the locale indicates Unicode rules.  For
17322              * non-locale, we just use the general list */
17323             if (LOC) {
17324                 use_list = &only_utf8_locale_list;
17325             }
17326             else {
17327                 use_list = &cp_list;
17328             }
17329
17330             /* Only the characters in this class that participate in folds need
17331              * be checked.  Get the intersection of this class and all the
17332              * possible characters that are foldable.  This can quickly narrow
17333              * down a large class */
17334             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17335                                   &fold_intersection);
17336
17337             /* The folds for all the Latin1 characters are hard-coded into this
17338              * program, but we have to go out to disk to get the others. */
17339             if (invlist_highest(cp_foldable_list) >= 256) {
17340
17341                 /* This is a hash that for a particular fold gives all
17342                  * characters that are involved in it */
17343                 if (! PL_utf8_foldclosures) {
17344                     _load_PL_utf8_foldclosures();
17345                 }
17346             }
17347
17348             /* Now look at the foldable characters in this class individually */
17349             invlist_iterinit(fold_intersection);
17350             while (invlist_iternext(fold_intersection, &start, &end)) {
17351                 UV j;
17352
17353                 /* Look at every character in the range */
17354                 for (j = start; j <= end; j++) {
17355                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17356                     STRLEN foldlen;
17357                     SV** listp;
17358
17359                     if (j < 256) {
17360
17361                         if (IS_IN_SOME_FOLD_L1(j)) {
17362
17363                             /* ASCII is always matched; non-ASCII is matched
17364                              * only under Unicode rules (which could happen
17365                              * under /l if the locale is a UTF-8 one */
17366                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17367                                 *use_list = add_cp_to_invlist(*use_list,
17368                                                             PL_fold_latin1[j]);
17369                             }
17370                             else {
17371                                 has_upper_latin1_only_utf8_matches
17372                                     = add_cp_to_invlist(
17373                                             has_upper_latin1_only_utf8_matches,
17374                                             PL_fold_latin1[j]);
17375                             }
17376                         }
17377
17378                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17379                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17380                         {
17381                             add_above_Latin1_folds(pRExC_state,
17382                                                    (U8) j,
17383                                                    use_list);
17384                         }
17385                         continue;
17386                     }
17387
17388                     /* Here is an above Latin1 character.  We don't have the
17389                      * rules hard-coded for it.  First, get its fold.  This is
17390                      * the simple fold, as the multi-character folds have been
17391                      * handled earlier and separated out */
17392                     _to_uni_fold_flags(j, foldbuf, &foldlen,
17393                                                         (ASCII_FOLD_RESTRICTED)
17394                                                         ? FOLD_FLAGS_NOMIX_ASCII
17395                                                         : 0);
17396
17397                     /* Single character fold of above Latin1.  Add everything in
17398                     * its fold closure to the list that this node should match.
17399                     * The fold closures data structure is a hash with the keys
17400                     * being the UTF-8 of every character that is folded to, like
17401                     * 'k', and the values each an array of all code points that
17402                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
17403                     * Multi-character folds are not included */
17404                     if ((listp = hv_fetch(PL_utf8_foldclosures,
17405                                         (char *) foldbuf, foldlen, FALSE)))
17406                     {
17407                         AV* list = (AV*) *listp;
17408                         IV k;
17409                         for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
17410                             SV** c_p = av_fetch(list, k, FALSE);
17411                             UV c;
17412                             assert(c_p);
17413
17414                             c = SvUV(*c_p);
17415
17416                             /* /aa doesn't allow folds between ASCII and non- */
17417                             if ((ASCII_FOLD_RESTRICTED
17418                                 && (isASCII(c) != isASCII(j))))
17419                             {
17420                                 continue;
17421                             }
17422
17423                             /* Folds under /l which cross the 255/256 boundary
17424                              * are added to a separate list.  (These are valid
17425                              * only when the locale is UTF-8.) */
17426                             if (c < 256 && LOC) {
17427                                 *use_list = add_cp_to_invlist(*use_list, c);
17428                                 continue;
17429                             }
17430
17431                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17432                             {
17433                                 cp_list = add_cp_to_invlist(cp_list, c);
17434                             }
17435                             else {
17436                                 /* Similarly folds involving non-ascii Latin1
17437                                 * characters under /d are added to their list */
17438                                 has_upper_latin1_only_utf8_matches
17439                                         = add_cp_to_invlist(
17440                                            has_upper_latin1_only_utf8_matches,
17441                                            c);
17442                             }
17443                         }
17444                     }
17445                 }
17446             }
17447             SvREFCNT_dec_NN(fold_intersection);
17448         }
17449
17450         /* Now that we have finished adding all the folds, there is no reason
17451          * to keep the foldable list separate */
17452         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17453         SvREFCNT_dec_NN(cp_foldable_list);
17454     }
17455
17456     /* And combine the result (if any) with any inversion lists from posix
17457      * classes.  The lists are kept separate up to now because we don't want to
17458      * fold the classes (folding of those is automatically handled by the swash
17459      * fetching code) */
17460     if (simple_posixes) {   /* These are the classes known to be unaffected by
17461                                /a, /aa, and /d */
17462         if (cp_list) {
17463             _invlist_union(cp_list, simple_posixes, &cp_list);
17464             SvREFCNT_dec_NN(simple_posixes);
17465         }
17466         else {
17467             cp_list = simple_posixes;
17468         }
17469     }
17470     if (posixes || nposixes) {
17471
17472         /* We have to adjust /a and /aa */
17473         if (AT_LEAST_ASCII_RESTRICTED) {
17474
17475             /* Under /a and /aa, nothing above ASCII matches these */
17476             if (posixes) {
17477                 _invlist_intersection(posixes,
17478                                     PL_XPosix_ptrs[_CC_ASCII],
17479                                     &posixes);
17480             }
17481
17482             /* Under /a and /aa, everything above ASCII matches these
17483              * complements */
17484             if (nposixes) {
17485                 _invlist_union_complement_2nd(nposixes,
17486                                               PL_XPosix_ptrs[_CC_ASCII],
17487                                               &nposixes);
17488             }
17489         }
17490
17491         if (! DEPENDS_SEMANTICS) {
17492
17493             /* For everything but /d, we can just add the current 'posixes' and
17494              * 'nposixes' to the main list */
17495             if (posixes) {
17496                 if (cp_list) {
17497                     _invlist_union(cp_list, posixes, &cp_list);
17498                     SvREFCNT_dec_NN(posixes);
17499                 }
17500                 else {
17501                     cp_list = posixes;
17502                 }
17503             }
17504             if (nposixes) {
17505                 if (cp_list) {
17506                     _invlist_union(cp_list, nposixes, &cp_list);
17507                     SvREFCNT_dec_NN(nposixes);
17508                 }
17509                 else {
17510                     cp_list = nposixes;
17511                 }
17512             }
17513         }
17514         else {
17515             /* Under /d, things like \w match upper Latin1 characters only if
17516              * the target string is in UTF-8.  But things like \W match all the
17517              * upper Latin1 characters if the target string is not in UTF-8.
17518              *
17519              * Handle the case where there something like \W separately */
17520             if (nposixes) {
17521                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
17522
17523                 /* A complemented posix class matches all upper Latin1
17524                  * characters if not in UTF-8.  And it matches just certain
17525                  * ones when in UTF-8.  That means those certain ones are
17526                  * matched regardless, so can just be added to the
17527                  * unconditional list */
17528                 if (cp_list) {
17529                     _invlist_union(cp_list, nposixes, &cp_list);
17530                     SvREFCNT_dec_NN(nposixes);
17531                     nposixes = NULL;
17532                 }
17533                 else {
17534                     cp_list = nposixes;
17535                 }
17536
17537                 /* Likewise for 'posixes' */
17538                 _invlist_union(posixes, cp_list, &cp_list);
17539
17540                 /* Likewise for anything else in the range that matched only
17541                  * under UTF-8 */
17542                 if (has_upper_latin1_only_utf8_matches) {
17543                     _invlist_union(cp_list,
17544                                    has_upper_latin1_only_utf8_matches,
17545                                    &cp_list);
17546                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17547                     has_upper_latin1_only_utf8_matches = NULL;
17548                 }
17549
17550                 /* If we don't match all the upper Latin1 characters regardless
17551                  * of UTF-8ness, we have to set a flag to match the rest when
17552                  * not in UTF-8 */
17553                 _invlist_subtract(only_non_utf8_list, cp_list,
17554                                   &only_non_utf8_list);
17555                 if (_invlist_len(only_non_utf8_list) != 0) {
17556                     ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17557                 }
17558             }
17559             else {
17560                 /* Here there were no complemented posix classes.  That means
17561                  * the upper Latin1 characters in 'posixes' match only when the
17562                  * target string is in UTF-8.  So we have to add them to the
17563                  * list of those types of code points, while adding the
17564                  * remainder to the unconditional list.
17565                  *
17566                  * First calculate what they are */
17567                 SV* nonascii_but_latin1_properties = NULL;
17568                 _invlist_intersection(posixes, PL_UpperLatin1,
17569                                       &nonascii_but_latin1_properties);
17570
17571                 /* And add them to the final list of such characters. */
17572                 _invlist_union(has_upper_latin1_only_utf8_matches,
17573                                nonascii_but_latin1_properties,
17574                                &has_upper_latin1_only_utf8_matches);
17575
17576                 /* Remove them from what now becomes the unconditional list */
17577                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
17578                                   &posixes);
17579
17580                 /* And add those unconditional ones to the final list */
17581                 if (cp_list) {
17582                     _invlist_union(cp_list, posixes, &cp_list);
17583                     SvREFCNT_dec_NN(posixes);
17584                     posixes = NULL;
17585                 }
17586                 else {
17587                     cp_list = posixes;
17588                 }
17589
17590                 SvREFCNT_dec(nonascii_but_latin1_properties);
17591
17592                 /* Get rid of any characters that we now know are matched
17593                  * unconditionally from the conditional list, which may make
17594                  * that list empty */
17595                 _invlist_subtract(has_upper_latin1_only_utf8_matches,
17596                                   cp_list,
17597                                   &has_upper_latin1_only_utf8_matches);
17598                 if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
17599                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17600                     has_upper_latin1_only_utf8_matches = NULL;
17601                 }
17602             }
17603         }
17604     }
17605
17606     /* And combine the result (if any) with any inversion list from properties.
17607      * The lists are kept separate up to now so that we can distinguish the two
17608      * in regards to matching above-Unicode.  A run-time warning is generated
17609      * if a Unicode property is matched against a non-Unicode code point. But,
17610      * we allow user-defined properties to match anything, without any warning,
17611      * and we also suppress the warning if there is a portion of the character
17612      * class that isn't a Unicode property, and which matches above Unicode, \W
17613      * or [\x{110000}] for example.
17614      * (Note that in this case, unlike the Posix one above, there is no
17615      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
17616      * forces Unicode semantics */
17617     if (properties) {
17618         if (cp_list) {
17619
17620             /* If it matters to the final outcome, see if a non-property
17621              * component of the class matches above Unicode.  If so, the
17622              * warning gets suppressed.  This is true even if just a single
17623              * such code point is specified, as, though not strictly correct if
17624              * another such code point is matched against, the fact that they
17625              * are using above-Unicode code points indicates they should know
17626              * the issues involved */
17627             if (warn_super) {
17628                 warn_super = ! (invert
17629                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
17630             }
17631
17632             _invlist_union(properties, cp_list, &cp_list);
17633             SvREFCNT_dec_NN(properties);
17634         }
17635         else {
17636             cp_list = properties;
17637         }
17638
17639         if (warn_super) {
17640             ANYOF_FLAGS(ret)
17641              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17642
17643             /* Because an ANYOF node is the only one that warns, this node
17644              * can't be optimized into something else */
17645             optimizable = FALSE;
17646         }
17647     }
17648
17649     /* Here, we have calculated what code points should be in the character
17650      * class.
17651      *
17652      * Now we can see about various optimizations.  Fold calculation (which we
17653      * did above) needs to take place before inversion.  Otherwise /[^k]/i
17654      * would invert to include K, which under /i would match k, which it
17655      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
17656      * folded until runtime */
17657
17658     /* If we didn't do folding, it's because some information isn't available
17659      * until runtime; set the run-time fold flag for these.  (We don't have to
17660      * worry about properties folding, as that is taken care of by the swash
17661      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
17662      * locales, or the class matches at least one 0-255 range code point */
17663     if (LOC && FOLD) {
17664
17665         /* Some things on the list might be unconditionally included because of
17666          * other components.  Remove them, and clean up the list if it goes to
17667          * 0 elements */
17668         if (only_utf8_locale_list && cp_list) {
17669             _invlist_subtract(only_utf8_locale_list, cp_list,
17670                               &only_utf8_locale_list);
17671
17672             if (_invlist_len(only_utf8_locale_list) == 0) {
17673                 SvREFCNT_dec_NN(only_utf8_locale_list);
17674                 only_utf8_locale_list = NULL;
17675             }
17676         }
17677         if (only_utf8_locale_list) {
17678             ANYOF_FLAGS(ret)
17679                  |=  ANYOFL_FOLD
17680                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
17681         }
17682         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
17683             UV start, end;
17684             invlist_iterinit(cp_list);
17685             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
17686                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
17687             }
17688             invlist_iterfinish(cp_list);
17689         }
17690     }
17691     else if (   DEPENDS_SEMANTICS
17692              && (    has_upper_latin1_only_utf8_matches
17693                  || (ANYOF_FLAGS(ret) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
17694     {
17695         OP(ret) = ANYOFD;
17696         optimizable = FALSE;
17697     }
17698
17699
17700     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
17701      * at compile time.  Besides not inverting folded locale now, we can't
17702      * invert if there are things such as \w, which aren't known until runtime
17703      * */
17704     if (cp_list
17705         && invert
17706         && OP(ret) != ANYOFD
17707         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
17708         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17709     {
17710         _invlist_invert(cp_list);
17711
17712         /* Any swash can't be used as-is, because we've inverted things */
17713         if (swash) {
17714             SvREFCNT_dec_NN(swash);
17715             swash = NULL;
17716         }
17717
17718         /* Clear the invert flag since have just done it here */
17719         invert = FALSE;
17720     }
17721
17722     if (ret_invlist) {
17723         assert(cp_list);
17724
17725         *ret_invlist = cp_list;
17726         SvREFCNT_dec(swash);
17727
17728         /* Discard the generated node */
17729         if (SIZE_ONLY) {
17730             RExC_size = orig_size;
17731         }
17732         else {
17733             RExC_emit = orig_emit;
17734         }
17735         return orig_emit;
17736     }
17737
17738     /* Some character classes are equivalent to other nodes.  Such nodes take
17739      * up less room and generally fewer operations to execute than ANYOF nodes.
17740      * Above, we checked for and optimized into some such equivalents for
17741      * certain common classes that are easy to test.  Getting to this point in
17742      * the code means that the class didn't get optimized there.  Since this
17743      * code is only executed in Pass 2, it is too late to save space--it has
17744      * been allocated in Pass 1, and currently isn't given back.  But turning
17745      * things into an EXACTish node can allow the optimizer to join it to any
17746      * adjacent such nodes.  And if the class is equivalent to things like /./,
17747      * expensive run-time swashes can be avoided.  Now that we have more
17748      * complete information, we can find things necessarily missed by the
17749      * earlier code.  Another possible "optimization" that isn't done is that
17750      * something like [Ee] could be changed into an EXACTFU.  khw tried this
17751      * and found that the ANYOF is faster, including for code points not in the
17752      * bitmap.  This still might make sense to do, provided it got joined with
17753      * an adjacent node(s) to create a longer EXACTFU one.  This could be
17754      * accomplished by creating a pseudo ANYOF_EXACTFU node type that the join
17755      * routine would know is joinable.  If that didn't happen, the node type
17756      * could then be made a straight ANYOF */
17757
17758     if (optimizable && cp_list && ! invert) {
17759         UV start, end;
17760         U8 op = END;  /* The optimzation node-type */
17761         int posix_class = -1;   /* Illegal value */
17762         const char * cur_parse= RExC_parse;
17763
17764         invlist_iterinit(cp_list);
17765         if (! invlist_iternext(cp_list, &start, &end)) {
17766
17767             /* Here, the list is empty.  This happens, for example, when a
17768              * Unicode property that doesn't match anything is the only element
17769              * in the character class (perluniprops.pod notes such properties).
17770              * */
17771             op = OPFAIL;
17772             *flagp |= HASWIDTH|SIMPLE;
17773         }
17774         else if (start == end) {    /* The range is a single code point */
17775             if (! invlist_iternext(cp_list, &start, &end)
17776
17777                     /* Don't do this optimization if it would require changing
17778                      * the pattern to UTF-8 */
17779                 && (start < 256 || UTF))
17780             {
17781                 /* Here, the list contains a single code point.  Can optimize
17782                  * into an EXACTish node */
17783
17784                 value = start;
17785
17786                 if (! FOLD) {
17787                     op = (LOC)
17788                          ? EXACTL
17789                          : EXACT;
17790                 }
17791                 else if (LOC) {
17792
17793                     /* A locale node under folding with one code point can be
17794                      * an EXACTFL, as its fold won't be calculated until
17795                      * runtime */
17796                     op = EXACTFL;
17797                 }
17798                 else {
17799
17800                     /* Here, we are generally folding, but there is only one
17801                      * code point to match.  If we have to, we use an EXACT
17802                      * node, but it would be better for joining with adjacent
17803                      * nodes in the optimization pass if we used the same
17804                      * EXACTFish node that any such are likely to be.  We can
17805                      * do this iff the code point doesn't participate in any
17806                      * folds.  For example, an EXACTF of a colon is the same as
17807                      * an EXACT one, since nothing folds to or from a colon. */
17808                     if (value < 256) {
17809                         if (IS_IN_SOME_FOLD_L1(value)) {
17810                             op = EXACT;
17811                         }
17812                     }
17813                     else {
17814                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
17815                             op = EXACT;
17816                         }
17817                     }
17818
17819                     /* If we haven't found the node type, above, it means we
17820                      * can use the prevailing one */
17821                     if (op == END) {
17822                         op = compute_EXACTish(pRExC_state);
17823                     }
17824                 }
17825             }
17826         }   /* End of first range contains just a single code point */
17827         else if (start == 0) {
17828             if (end == UV_MAX) {
17829                 op = SANY;
17830                 *flagp |= HASWIDTH|SIMPLE;
17831                 MARK_NAUGHTY(1);
17832             }
17833             else if (end == '\n' - 1
17834                     && invlist_iternext(cp_list, &start, &end)
17835                     && start == '\n' + 1 && end == UV_MAX)
17836             {
17837                 op = REG_ANY;
17838                 *flagp |= HASWIDTH|SIMPLE;
17839                 MARK_NAUGHTY(1);
17840             }
17841         }
17842         invlist_iterfinish(cp_list);
17843
17844         if (op == END) {
17845             const UV cp_list_len = _invlist_len(cp_list);
17846             const UV* cp_list_array = invlist_array(cp_list);
17847
17848             /* Here, didn't find an optimization.  See if this matches any of
17849              * the POSIX classes.  These run slightly faster for above-Unicode
17850              * code points, so don't bother with POSIXA ones nor the 2 that
17851              * have no above-Unicode matches.  We can avoid these checks unless
17852              * the ANYOF matches at least as high as the lowest POSIX one
17853              * (which was manually found to be \v.  The actual code point may
17854              * increase in later Unicode releases, if a higher code point is
17855              * assigned to be \v, but this code will never break.  It would
17856              * just mean we could execute the checks for posix optimizations
17857              * unnecessarily) */
17858
17859             if (cp_list_array[cp_list_len-1] > 0x2029) {
17860                 for (posix_class = 0;
17861                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
17862                      posix_class++)
17863                 {
17864                     int try_inverted;
17865                     if (posix_class == _CC_ASCII || posix_class == _CC_CNTRL) {
17866                         continue;
17867                     }
17868                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
17869
17870                         /* Check if matches normal or inverted */
17871                         if (_invlistEQ(cp_list,
17872                                        PL_XPosix_ptrs[posix_class],
17873                                        try_inverted))
17874                         {
17875                             op = (try_inverted)
17876                                  ? NPOSIXU
17877                                  : POSIXU;
17878                             *flagp |= HASWIDTH|SIMPLE;
17879                             goto found_posix;
17880                         }
17881                     }
17882                 }
17883               found_posix: ;
17884             }
17885         }
17886
17887         if (op != END) {
17888             RExC_parse = (char *)orig_parse;
17889             RExC_emit = (regnode *)orig_emit;
17890
17891             if (regarglen[op]) {
17892                 ret = reganode(pRExC_state, op, 0);
17893             } else {
17894                 ret = reg_node(pRExC_state, op);
17895             }
17896
17897             RExC_parse = (char *)cur_parse;
17898
17899             if (PL_regkind[op] == EXACT) {
17900                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17901                                            TRUE /* downgradable to EXACT */
17902                                           );
17903             }
17904             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17905                 FLAGS(ret) = posix_class;
17906             }
17907
17908             SvREFCNT_dec_NN(cp_list);
17909             return ret;
17910         }
17911     }
17912
17913     /* Here, <cp_list> contains all the code points we can determine at
17914      * compile time that match under all conditions.  Go through it, and
17915      * for things that belong in the bitmap, put them there, and delete from
17916      * <cp_list>.  While we are at it, see if everything above 255 is in the
17917      * list, and if so, set a flag to speed up execution */
17918
17919     populate_ANYOF_from_invlist(ret, &cp_list);
17920
17921     if (invert) {
17922         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
17923     }
17924
17925     /* Here, the bitmap has been populated with all the Latin1 code points that
17926      * always match.  Can now add to the overall list those that match only
17927      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
17928      * */
17929     if (has_upper_latin1_only_utf8_matches) {
17930         if (cp_list) {
17931             _invlist_union(cp_list,
17932                            has_upper_latin1_only_utf8_matches,
17933                            &cp_list);
17934             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17935         }
17936         else {
17937             cp_list = has_upper_latin1_only_utf8_matches;
17938         }
17939         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17940     }
17941
17942     /* If there is a swash and more than one element, we can't use the swash in
17943      * the optimization below. */
17944     if (swash && element_count > 1) {
17945         SvREFCNT_dec_NN(swash);
17946         swash = NULL;
17947     }
17948
17949     /* Note that the optimization of using 'swash' if it is the only thing in
17950      * the class doesn't have us change swash at all, so it can include things
17951      * that are also in the bitmap; otherwise we have purposely deleted that
17952      * duplicate information */
17953     set_ANYOF_arg(pRExC_state, ret, cp_list,
17954                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17955                    ? listsv : NULL,
17956                   only_utf8_locale_list,
17957                   swash, has_user_defined_property);
17958
17959     *flagp |= HASWIDTH|SIMPLE;
17960
17961     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
17962         RExC_contains_locale = 1;
17963     }
17964
17965     return ret;
17966 }
17967
17968 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
17969
17970 STATIC void
17971 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
17972                 regnode* const node,
17973                 SV* const cp_list,
17974                 SV* const runtime_defns,
17975                 SV* const only_utf8_locale_list,
17976                 SV* const swash,
17977                 const bool has_user_defined_property)
17978 {
17979     /* Sets the arg field of an ANYOF-type node 'node', using information about
17980      * the node passed-in.  If there is nothing outside the node's bitmap, the
17981      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
17982      * the count returned by add_data(), having allocated and stored an array,
17983      * av, that that count references, as follows:
17984      *  av[0] stores the character class description in its textual form.
17985      *        This is used later (regexec.c:Perl_regclass_swash()) to
17986      *        initialize the appropriate swash, and is also useful for dumping
17987      *        the regnode.  This is set to &PL_sv_undef if the textual
17988      *        description is not needed at run-time (as happens if the other
17989      *        elements completely define the class)
17990      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
17991      *        computed from av[0].  But if no further computation need be done,
17992      *        the swash is stored here now (and av[0] is &PL_sv_undef).
17993      *  av[2] stores the inversion list of code points that match only if the
17994      *        current locale is UTF-8
17995      *  av[3] stores the cp_list inversion list for use in addition or instead
17996      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
17997      *        (Otherwise everything needed is already in av[0] and av[1])
17998      *  av[4] is set if any component of the class is from a user-defined
17999      *        property; used only if av[3] exists */
18000
18001     UV n;
18002
18003     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
18004
18005     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
18006         assert(! (ANYOF_FLAGS(node)
18007                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
18008         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
18009     }
18010     else {
18011         AV * const av = newAV();
18012         SV *rv;
18013
18014         av_store(av, 0, (runtime_defns)
18015                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
18016         if (swash) {
18017             assert(cp_list);
18018             av_store(av, 1, swash);
18019             SvREFCNT_dec_NN(cp_list);
18020         }
18021         else {
18022             av_store(av, 1, &PL_sv_undef);
18023             if (cp_list) {
18024                 av_store(av, 3, cp_list);
18025                 av_store(av, 4, newSVuv(has_user_defined_property));
18026             }
18027         }
18028
18029         if (only_utf8_locale_list) {
18030             av_store(av, 2, only_utf8_locale_list);
18031         }
18032         else {
18033             av_store(av, 2, &PL_sv_undef);
18034         }
18035
18036         rv = newRV_noinc(MUTABLE_SV(av));
18037         n = add_data(pRExC_state, STR_WITH_LEN("s"));
18038         RExC_rxi->data->data[n] = (void*)rv;
18039         ARG_SET(node, n);
18040     }
18041 }
18042
18043 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
18044 SV *
18045 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
18046                                         const regnode* node,
18047                                         bool doinit,
18048                                         SV** listsvp,
18049                                         SV** only_utf8_locale_ptr,
18050                                         SV** output_invlist)
18051
18052 {
18053     /* For internal core use only.
18054      * Returns the swash for the input 'node' in the regex 'prog'.
18055      * If <doinit> is 'true', will attempt to create the swash if not already
18056      *    done.
18057      * If <listsvp> is non-null, will return the printable contents of the
18058      *    swash.  This can be used to get debugging information even before the
18059      *    swash exists, by calling this function with 'doinit' set to false, in
18060      *    which case the components that will be used to eventually create the
18061      *    swash are returned  (in a printable form).
18062      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
18063      *    store an inversion list of code points that should match only if the
18064      *    execution-time locale is a UTF-8 one.
18065      * If <output_invlist> is not NULL, it is where this routine is to store an
18066      *    inversion list of the code points that would be instead returned in
18067      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
18068      *    when this parameter is used, is just the non-code point data that
18069      *    will go into creating the swash.  This currently should be just
18070      *    user-defined properties whose definitions were not known at compile
18071      *    time.  Using this parameter allows for easier manipulation of the
18072      *    swash's data by the caller.  It is illegal to call this function with
18073      *    this parameter set, but not <listsvp>
18074      *
18075      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
18076      * that, in spite of this function's name, the swash it returns may include
18077      * the bitmap data as well */
18078
18079     SV *sw  = NULL;
18080     SV *si  = NULL;         /* Input swash initialization string */
18081     SV* invlist = NULL;
18082
18083     RXi_GET_DECL(prog,progi);
18084     const struct reg_data * const data = prog ? progi->data : NULL;
18085
18086     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
18087     assert(! output_invlist || listsvp);
18088
18089     if (data && data->count) {
18090         const U32 n = ARG(node);
18091
18092         if (data->what[n] == 's') {
18093             SV * const rv = MUTABLE_SV(data->data[n]);
18094             AV * const av = MUTABLE_AV(SvRV(rv));
18095             SV **const ary = AvARRAY(av);
18096             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
18097
18098             si = *ary;  /* ary[0] = the string to initialize the swash with */
18099
18100             if (av_tindex_skip_len_mg(av) >= 2) {
18101                 if (only_utf8_locale_ptr
18102                     && ary[2]
18103                     && ary[2] != &PL_sv_undef)
18104                 {
18105                     *only_utf8_locale_ptr = ary[2];
18106                 }
18107                 else {
18108                     assert(only_utf8_locale_ptr);
18109                     *only_utf8_locale_ptr = NULL;
18110                 }
18111
18112                 /* Elements 3 and 4 are either both present or both absent. [3]
18113                  * is any inversion list generated at compile time; [4]
18114                  * indicates if that inversion list has any user-defined
18115                  * properties in it. */
18116                 if (av_tindex_skip_len_mg(av) >= 3) {
18117                     invlist = ary[3];
18118                     if (SvUV(ary[4])) {
18119                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
18120                     }
18121                 }
18122                 else {
18123                     invlist = NULL;
18124                 }
18125             }
18126
18127             /* Element [1] is reserved for the set-up swash.  If already there,
18128              * return it; if not, create it and store it there */
18129             if (ary[1] && SvROK(ary[1])) {
18130                 sw = ary[1];
18131             }
18132             else if (doinit && ((si && si != &PL_sv_undef)
18133                                  || (invlist && invlist != &PL_sv_undef))) {
18134                 assert(si);
18135                 sw = _core_swash_init("utf8", /* the utf8 package */
18136                                       "", /* nameless */
18137                                       si,
18138                                       1, /* binary */
18139                                       0, /* not from tr/// */
18140                                       invlist,
18141                                       &swash_init_flags);
18142                 (void)av_store(av, 1, sw);
18143             }
18144         }
18145     }
18146
18147     /* If requested, return a printable version of what this swash matches */
18148     if (listsvp) {
18149         SV* matches_string = NULL;
18150
18151         /* The swash should be used, if possible, to get the data, as it
18152          * contains the resolved data.  But this function can be called at
18153          * compile-time, before everything gets resolved, in which case we
18154          * return the currently best available information, which is the string
18155          * that will eventually be used to do that resolving, 'si' */
18156         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
18157             && (si && si != &PL_sv_undef))
18158         {
18159             /* Here, we only have 'si' (and possibly some passed-in data in
18160              * 'invlist', which is handled below)  If the caller only wants
18161              * 'si', use that.  */
18162             if (! output_invlist) {
18163                 matches_string = newSVsv(si);
18164             }
18165             else {
18166                 /* But if the caller wants an inversion list of the node, we
18167                  * need to parse 'si' and place as much as possible in the
18168                  * desired output inversion list, making 'matches_string' only
18169                  * contain the currently unresolvable things */
18170                 const char *si_string = SvPVX(si);
18171                 STRLEN remaining = SvCUR(si);
18172                 UV prev_cp = 0;
18173                 U8 count = 0;
18174
18175                 /* Ignore everything before the first new-line */
18176                 while (*si_string != '\n' && remaining > 0) {
18177                     si_string++;
18178                     remaining--;
18179                 }
18180                 assert(remaining > 0);
18181
18182                 si_string++;
18183                 remaining--;
18184
18185                 while (remaining > 0) {
18186
18187                     /* The data consists of just strings defining user-defined
18188                      * property names, but in prior incarnations, and perhaps
18189                      * somehow from pluggable regex engines, it could still
18190                      * hold hex code point definitions.  Each component of a
18191                      * range would be separated by a tab, and each range by a
18192                      * new-line.  If these are found, instead add them to the
18193                      * inversion list */
18194                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
18195                                      |PERL_SCAN_SILENT_NON_PORTABLE;
18196                     STRLEN len = remaining;
18197                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
18198
18199                     /* If the hex decode routine found something, it should go
18200                      * up to the next \n */
18201                     if (   *(si_string + len) == '\n') {
18202                         if (count) {    /* 2nd code point on line */
18203                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
18204                         }
18205                         else {
18206                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
18207                         }
18208                         count = 0;
18209                         goto prepare_for_next_iteration;
18210                     }
18211
18212                     /* If the hex decode was instead for the lower range limit,
18213                      * save it, and go parse the upper range limit */
18214                     if (*(si_string + len) == '\t') {
18215                         assert(count == 0);
18216
18217                         prev_cp = cp;
18218                         count = 1;
18219                       prepare_for_next_iteration:
18220                         si_string += len + 1;
18221                         remaining -= len + 1;
18222                         continue;
18223                     }
18224
18225                     /* Here, didn't find a legal hex number.  Just add it from
18226                      * here to the next \n */
18227
18228                     remaining -= len;
18229                     while (*(si_string + len) != '\n' && remaining > 0) {
18230                         remaining--;
18231                         len++;
18232                     }
18233                     if (*(si_string + len) == '\n') {
18234                         len++;
18235                         remaining--;
18236                     }
18237                     if (matches_string) {
18238                         sv_catpvn(matches_string, si_string, len - 1);
18239                     }
18240                     else {
18241                         matches_string = newSVpvn(si_string, len - 1);
18242                     }
18243                     si_string += len;
18244                     sv_catpvs(matches_string, " ");
18245                 } /* end of loop through the text */
18246
18247                 assert(matches_string);
18248                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
18249                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
18250                 }
18251             } /* end of has an 'si' but no swash */
18252         }
18253
18254         /* If we have a swash in place, its equivalent inversion list was above
18255          * placed into 'invlist'.  If not, this variable may contain a stored
18256          * inversion list which is information beyond what is in 'si' */
18257         if (invlist) {
18258
18259             /* Again, if the caller doesn't want the output inversion list, put
18260              * everything in 'matches-string' */
18261             if (! output_invlist) {
18262                 if ( ! matches_string) {
18263                     matches_string = newSVpvs("\n");
18264                 }
18265                 sv_catsv(matches_string, invlist_contents(invlist,
18266                                                   TRUE /* traditional style */
18267                                                   ));
18268             }
18269             else if (! *output_invlist) {
18270                 *output_invlist = invlist_clone(invlist);
18271             }
18272             else {
18273                 _invlist_union(*output_invlist, invlist, output_invlist);
18274             }
18275         }
18276
18277         *listsvp = matches_string;
18278     }
18279
18280     return sw;
18281 }
18282 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18283
18284 /* reg_skipcomment()
18285
18286    Absorbs an /x style # comment from the input stream,
18287    returning a pointer to the first character beyond the comment, or if the
18288    comment terminates the pattern without anything following it, this returns
18289    one past the final character of the pattern (in other words, RExC_end) and
18290    sets the REG_RUN_ON_COMMENT_SEEN flag.
18291
18292    Note it's the callers responsibility to ensure that we are
18293    actually in /x mode
18294
18295 */
18296
18297 PERL_STATIC_INLINE char*
18298 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18299 {
18300     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18301
18302     assert(*p == '#');
18303
18304     while (p < RExC_end) {
18305         if (*(++p) == '\n') {
18306             return p+1;
18307         }
18308     }
18309
18310     /* we ran off the end of the pattern without ending the comment, so we have
18311      * to add an \n when wrapping */
18312     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18313     return p;
18314 }
18315
18316 STATIC void
18317 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18318                                 char ** p,
18319                                 const bool force_to_xmod
18320                          )
18321 {
18322     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18323      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18324      * is /x whitespace, advance '*p' so that on exit it points to the first
18325      * byte past all such white space and comments */
18326
18327     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18328
18329     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18330
18331     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18332
18333     for (;;) {
18334         if (RExC_end - (*p) >= 3
18335             && *(*p)     == '('
18336             && *(*p + 1) == '?'
18337             && *(*p + 2) == '#')
18338         {
18339             while (*(*p) != ')') {
18340                 if ((*p) == RExC_end)
18341                     FAIL("Sequence (?#... not terminated");
18342                 (*p)++;
18343             }
18344             (*p)++;
18345             continue;
18346         }
18347
18348         if (use_xmod) {
18349             const char * save_p = *p;
18350             while ((*p) < RExC_end) {
18351                 STRLEN len;
18352                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18353                     (*p) += len;
18354                 }
18355                 else if (*(*p) == '#') {
18356                     (*p) = reg_skipcomment(pRExC_state, (*p));
18357                 }
18358                 else {
18359                     break;
18360                 }
18361             }
18362             if (*p != save_p) {
18363                 continue;
18364             }
18365         }
18366
18367         break;
18368     }
18369
18370     return;
18371 }
18372
18373 /* nextchar()
18374
18375    Advances the parse position by one byte, unless that byte is the beginning
18376    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
18377    those two cases, the parse position is advanced beyond all such comments and
18378    white space.
18379
18380    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
18381 */
18382
18383 STATIC void
18384 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
18385 {
18386     PERL_ARGS_ASSERT_NEXTCHAR;
18387
18388     if (RExC_parse < RExC_end) {
18389         assert(   ! UTF
18390                || UTF8_IS_INVARIANT(*RExC_parse)
18391                || UTF8_IS_START(*RExC_parse));
18392
18393         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
18394
18395         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
18396                                 FALSE /* Don't force /x */ );
18397     }
18398 }
18399
18400 STATIC regnode *
18401 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
18402 {
18403     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
18404      * space.  In pass1, it aligns and increments RExC_size; in pass2,
18405      * RExC_emit */
18406
18407     regnode * const ret = RExC_emit;
18408     GET_RE_DEBUG_FLAGS_DECL;
18409
18410     PERL_ARGS_ASSERT_REGNODE_GUTS;
18411
18412     assert(extra_size >= regarglen[op]);
18413
18414     if (SIZE_ONLY) {
18415         SIZE_ALIGN(RExC_size);
18416         RExC_size += 1 + extra_size;
18417         return(ret);
18418     }
18419     if (RExC_emit >= RExC_emit_bound)
18420         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
18421                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
18422
18423     NODE_ALIGN_FILL(ret);
18424 #ifndef RE_TRACK_PATTERN_OFFSETS
18425     PERL_UNUSED_ARG(name);
18426 #else
18427     if (RExC_offsets) {         /* MJD */
18428         MJD_OFFSET_DEBUG(
18429               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
18430               name, __LINE__,
18431               PL_reg_name[op],
18432               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
18433                 ? "Overwriting end of array!\n" : "OK",
18434               (UV)(RExC_emit - RExC_emit_start),
18435               (UV)(RExC_parse - RExC_start),
18436               (UV)RExC_offsets[0]));
18437         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
18438     }
18439 #endif
18440     return(ret);
18441 }
18442
18443 /*
18444 - reg_node - emit a node
18445 */
18446 STATIC regnode *                        /* Location. */
18447 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
18448 {
18449     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
18450
18451     PERL_ARGS_ASSERT_REG_NODE;
18452
18453     assert(regarglen[op] == 0);
18454
18455     if (PASS2) {
18456         regnode *ptr = ret;
18457         FILL_ADVANCE_NODE(ptr, op);
18458         RExC_emit = ptr;
18459     }
18460     return(ret);
18461 }
18462
18463 /*
18464 - reganode - emit a node with an argument
18465 */
18466 STATIC regnode *                        /* Location. */
18467 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
18468 {
18469     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
18470
18471     PERL_ARGS_ASSERT_REGANODE;
18472
18473     assert(regarglen[op] == 1);
18474
18475     if (PASS2) {
18476         regnode *ptr = ret;
18477         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
18478         RExC_emit = ptr;
18479     }
18480     return(ret);
18481 }
18482
18483 STATIC regnode *
18484 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
18485 {
18486     /* emit a node with U32 and I32 arguments */
18487
18488     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
18489
18490     PERL_ARGS_ASSERT_REG2LANODE;
18491
18492     assert(regarglen[op] == 2);
18493
18494     if (PASS2) {
18495         regnode *ptr = ret;
18496         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
18497         RExC_emit = ptr;
18498     }
18499     return(ret);
18500 }
18501
18502 /*
18503 - reginsert - insert an operator in front of already-emitted operand
18504 *
18505 * Means relocating the operand.
18506 *
18507 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
18508 * set up NEXT_OFF() of the inserted node if needed. Something like this:
18509 *
18510 * reginsert(pRExC, OPFAIL, orig_emit, depth+1);
18511 * if (PASS2)
18512 *     NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
18513 *
18514 */
18515 STATIC void
18516 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth)
18517 {
18518     regnode *src;
18519     regnode *dst;
18520     regnode *place;
18521     const int offset = regarglen[(U8)op];
18522     const int size = NODE_STEP_REGNODE + offset;
18523     GET_RE_DEBUG_FLAGS_DECL;
18524
18525     PERL_ARGS_ASSERT_REGINSERT;
18526     PERL_UNUSED_CONTEXT;
18527     PERL_UNUSED_ARG(depth);
18528 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
18529     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
18530     if (SIZE_ONLY) {
18531         RExC_size += size;
18532         return;
18533     }
18534     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
18535                                     studying. If this is wrong then we need to adjust RExC_recurse
18536                                     below like we do with RExC_open_parens/RExC_close_parens. */
18537     src = RExC_emit;
18538     RExC_emit += size;
18539     dst = RExC_emit;
18540     if (RExC_open_parens) {
18541         int paren;
18542         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
18543         /* remember that RExC_npar is rex->nparens + 1,
18544          * iow it is 1 more than the number of parens seen in
18545          * the pattern so far. */
18546         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
18547             /* note, RExC_open_parens[0] is the start of the
18548              * regex, it can't move. RExC_close_parens[0] is the end
18549              * of the regex, it *can* move. */
18550             if ( paren && RExC_open_parens[paren] >= operand ) {
18551                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
18552                 RExC_open_parens[paren] += size;
18553             } else {
18554                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
18555             }
18556             if ( RExC_close_parens[paren] >= operand ) {
18557                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
18558                 RExC_close_parens[paren] += size;
18559             } else {
18560                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
18561             }
18562         }
18563     }
18564     if (RExC_end_op)
18565         RExC_end_op += size;
18566
18567     while (src > operand) {
18568         StructCopy(--src, --dst, regnode);
18569 #ifdef RE_TRACK_PATTERN_OFFSETS
18570         if (RExC_offsets) {     /* MJD 20010112 */
18571             MJD_OFFSET_DEBUG(
18572                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
18573                   "reg_insert",
18574                   __LINE__,
18575                   PL_reg_name[op],
18576                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
18577                     ? "Overwriting end of array!\n" : "OK",
18578                   (UV)(src - RExC_emit_start),
18579                   (UV)(dst - RExC_emit_start),
18580                   (UV)RExC_offsets[0]));
18581             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
18582             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
18583         }
18584 #endif
18585     }
18586
18587
18588     place = operand;            /* Op node, where operand used to be. */
18589 #ifdef RE_TRACK_PATTERN_OFFSETS
18590     if (RExC_offsets) {         /* MJD */
18591         MJD_OFFSET_DEBUG(
18592               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
18593               "reginsert",
18594               __LINE__,
18595               PL_reg_name[op],
18596               (UV)(place - RExC_emit_start) > RExC_offsets[0]
18597               ? "Overwriting end of array!\n" : "OK",
18598               (UV)(place - RExC_emit_start),
18599               (UV)(RExC_parse - RExC_start),
18600               (UV)RExC_offsets[0]));
18601         Set_Node_Offset(place, RExC_parse);
18602         Set_Node_Length(place, 1);
18603     }
18604 #endif
18605     src = NEXTOPER(place);
18606     FILL_ADVANCE_NODE(place, op);
18607     Zero(src, offset, regnode);
18608 }
18609
18610 /*
18611 - regtail - set the next-pointer at the end of a node chain of p to val.
18612 - SEE ALSO: regtail_study
18613 */
18614 STATIC void
18615 S_regtail(pTHX_ RExC_state_t * pRExC_state,
18616                 const regnode * const p,
18617                 const regnode * const val,
18618                 const U32 depth)
18619 {
18620     regnode *scan;
18621     GET_RE_DEBUG_FLAGS_DECL;
18622
18623     PERL_ARGS_ASSERT_REGTAIL;
18624 #ifndef DEBUGGING
18625     PERL_UNUSED_ARG(depth);
18626 #endif
18627
18628     if (SIZE_ONLY)
18629         return;
18630
18631     /* Find last node. */
18632     scan = (regnode *) p;
18633     for (;;) {
18634         regnode * const temp = regnext(scan);
18635         DEBUG_PARSE_r({
18636             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
18637             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18638             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
18639                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
18640                     (temp == NULL ? "->" : ""),
18641                     (temp == NULL ? PL_reg_name[OP(val)] : "")
18642             );
18643         });
18644         if (temp == NULL)
18645             break;
18646         scan = temp;
18647     }
18648
18649     if (reg_off_by_arg[OP(scan)]) {
18650         ARG_SET(scan, val - scan);
18651     }
18652     else {
18653         NEXT_OFF(scan) = val - scan;
18654     }
18655 }
18656
18657 #ifdef DEBUGGING
18658 /*
18659 - regtail_study - set the next-pointer at the end of a node chain of p to val.
18660 - Look for optimizable sequences at the same time.
18661 - currently only looks for EXACT chains.
18662
18663 This is experimental code. The idea is to use this routine to perform
18664 in place optimizations on branches and groups as they are constructed,
18665 with the long term intention of removing optimization from study_chunk so
18666 that it is purely analytical.
18667
18668 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
18669 to control which is which.
18670
18671 */
18672 /* TODO: All four parms should be const */
18673
18674 STATIC U8
18675 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
18676                       const regnode *val,U32 depth)
18677 {
18678     regnode *scan;
18679     U8 exact = PSEUDO;
18680 #ifdef EXPERIMENTAL_INPLACESCAN
18681     I32 min = 0;
18682 #endif
18683     GET_RE_DEBUG_FLAGS_DECL;
18684
18685     PERL_ARGS_ASSERT_REGTAIL_STUDY;
18686
18687
18688     if (SIZE_ONLY)
18689         return exact;
18690
18691     /* Find last node. */
18692
18693     scan = p;
18694     for (;;) {
18695         regnode * const temp = regnext(scan);
18696 #ifdef EXPERIMENTAL_INPLACESCAN
18697         if (PL_regkind[OP(scan)] == EXACT) {
18698             bool unfolded_multi_char;   /* Unexamined in this routine */
18699             if (join_exact(pRExC_state, scan, &min,
18700                            &unfolded_multi_char, 1, val, depth+1))
18701                 return EXACT;
18702         }
18703 #endif
18704         if ( exact ) {
18705             switch (OP(scan)) {
18706                 case EXACT:
18707                 case EXACTL:
18708                 case EXACTF:
18709                 case EXACTFA_NO_TRIE:
18710                 case EXACTFA:
18711                 case EXACTFU:
18712                 case EXACTFLU8:
18713                 case EXACTFU_SS:
18714                 case EXACTFL:
18715                         if( exact == PSEUDO )
18716                             exact= OP(scan);
18717                         else if ( exact != OP(scan) )
18718                             exact= 0;
18719                 case NOTHING:
18720                     break;
18721                 default:
18722                     exact= 0;
18723             }
18724         }
18725         DEBUG_PARSE_r({
18726             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
18727             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18728             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
18729                 SvPV_nolen_const(RExC_mysv),
18730                 REG_NODE_NUM(scan),
18731                 PL_reg_name[exact]);
18732         });
18733         if (temp == NULL)
18734             break;
18735         scan = temp;
18736     }
18737     DEBUG_PARSE_r({
18738         DEBUG_PARSE_MSG("");
18739         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
18740         Perl_re_printf( aTHX_
18741                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
18742                       SvPV_nolen_const(RExC_mysv),
18743                       (IV)REG_NODE_NUM(val),
18744                       (IV)(val - scan)
18745         );
18746     });
18747     if (reg_off_by_arg[OP(scan)]) {
18748         ARG_SET(scan, val - scan);
18749     }
18750     else {
18751         NEXT_OFF(scan) = val - scan;
18752     }
18753
18754     return exact;
18755 }
18756 #endif
18757
18758 /*
18759  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
18760  */
18761 #ifdef DEBUGGING
18762
18763 static void
18764 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
18765 {
18766     int bit;
18767     int set=0;
18768
18769     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18770
18771     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
18772         if (flags & (1<<bit)) {
18773             if (!set++ && lead)
18774                 Perl_re_printf( aTHX_  "%s",lead);
18775             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
18776         }
18777     }
18778     if (lead)  {
18779         if (set)
18780             Perl_re_printf( aTHX_  "\n");
18781         else
18782             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18783     }
18784 }
18785
18786 static void
18787 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
18788 {
18789     int bit;
18790     int set=0;
18791     regex_charset cs;
18792
18793     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18794
18795     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
18796         if (flags & (1<<bit)) {
18797             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
18798                 continue;
18799             }
18800             if (!set++ && lead)
18801                 Perl_re_printf( aTHX_  "%s",lead);
18802             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
18803         }
18804     }
18805     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
18806             if (!set++ && lead) {
18807                 Perl_re_printf( aTHX_  "%s",lead);
18808             }
18809             switch (cs) {
18810                 case REGEX_UNICODE_CHARSET:
18811                     Perl_re_printf( aTHX_  "UNICODE");
18812                     break;
18813                 case REGEX_LOCALE_CHARSET:
18814                     Perl_re_printf( aTHX_  "LOCALE");
18815                     break;
18816                 case REGEX_ASCII_RESTRICTED_CHARSET:
18817                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
18818                     break;
18819                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
18820                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
18821                     break;
18822                 default:
18823                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
18824                     break;
18825             }
18826     }
18827     if (lead)  {
18828         if (set)
18829             Perl_re_printf( aTHX_  "\n");
18830         else
18831             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18832     }
18833 }
18834 #endif
18835
18836 void
18837 Perl_regdump(pTHX_ const regexp *r)
18838 {
18839 #ifdef DEBUGGING
18840     SV * const sv = sv_newmortal();
18841     SV *dsv= sv_newmortal();
18842     RXi_GET_DECL(r,ri);
18843     GET_RE_DEBUG_FLAGS_DECL;
18844
18845     PERL_ARGS_ASSERT_REGDUMP;
18846
18847     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
18848
18849     /* Header fields of interest. */
18850     if (r->anchored_substr) {
18851         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
18852             RE_SV_DUMPLEN(r->anchored_substr), 30);
18853         Perl_re_printf( aTHX_
18854                       "anchored %s%s at %" IVdf " ",
18855                       s, RE_SV_TAIL(r->anchored_substr),
18856                       (IV)r->anchored_offset);
18857     } else if (r->anchored_utf8) {
18858         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
18859             RE_SV_DUMPLEN(r->anchored_utf8), 30);
18860         Perl_re_printf( aTHX_
18861                       "anchored utf8 %s%s at %" IVdf " ",
18862                       s, RE_SV_TAIL(r->anchored_utf8),
18863                       (IV)r->anchored_offset);
18864     }
18865     if (r->float_substr) {
18866         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
18867             RE_SV_DUMPLEN(r->float_substr), 30);
18868         Perl_re_printf( aTHX_
18869                       "floating %s%s at %" IVdf "..%" UVuf " ",
18870                       s, RE_SV_TAIL(r->float_substr),
18871                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18872     } else if (r->float_utf8) {
18873         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
18874             RE_SV_DUMPLEN(r->float_utf8), 30);
18875         Perl_re_printf( aTHX_
18876                       "floating utf8 %s%s at %" IVdf "..%" UVuf " ",
18877                       s, RE_SV_TAIL(r->float_utf8),
18878                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18879     }
18880     if (r->check_substr || r->check_utf8)
18881         Perl_re_printf( aTHX_
18882                       (const char *)
18883                       (r->check_substr == r->float_substr
18884                        && r->check_utf8 == r->float_utf8
18885                        ? "(checking floating" : "(checking anchored"));
18886     if (r->intflags & PREGf_NOSCAN)
18887         Perl_re_printf( aTHX_  " noscan");
18888     if (r->extflags & RXf_CHECK_ALL)
18889         Perl_re_printf( aTHX_  " isall");
18890     if (r->check_substr || r->check_utf8)
18891         Perl_re_printf( aTHX_  ") ");
18892
18893     if (ri->regstclass) {
18894         regprop(r, sv, ri->regstclass, NULL, NULL);
18895         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
18896     }
18897     if (r->intflags & PREGf_ANCH) {
18898         Perl_re_printf( aTHX_  "anchored");
18899         if (r->intflags & PREGf_ANCH_MBOL)
18900             Perl_re_printf( aTHX_  "(MBOL)");
18901         if (r->intflags & PREGf_ANCH_SBOL)
18902             Perl_re_printf( aTHX_  "(SBOL)");
18903         if (r->intflags & PREGf_ANCH_GPOS)
18904             Perl_re_printf( aTHX_  "(GPOS)");
18905         Perl_re_printf( aTHX_ " ");
18906     }
18907     if (r->intflags & PREGf_GPOS_SEEN)
18908         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
18909     if (r->intflags & PREGf_SKIP)
18910         Perl_re_printf( aTHX_  "plus ");
18911     if (r->intflags & PREGf_IMPLICIT)
18912         Perl_re_printf( aTHX_  "implicit ");
18913     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
18914     if (r->extflags & RXf_EVAL_SEEN)
18915         Perl_re_printf( aTHX_  "with eval ");
18916     Perl_re_printf( aTHX_  "\n");
18917     DEBUG_FLAGS_r({
18918         regdump_extflags("r->extflags: ",r->extflags);
18919         regdump_intflags("r->intflags: ",r->intflags);
18920     });
18921 #else
18922     PERL_ARGS_ASSERT_REGDUMP;
18923     PERL_UNUSED_CONTEXT;
18924     PERL_UNUSED_ARG(r);
18925 #endif  /* DEBUGGING */
18926 }
18927
18928 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
18929 #ifdef DEBUGGING
18930
18931 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
18932      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
18933      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
18934      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
18935      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
18936      || _CC_VERTSPACE != 15
18937 #   error Need to adjust order of anyofs[]
18938 #  endif
18939 static const char * const anyofs[] = {
18940     "\\w",
18941     "\\W",
18942     "\\d",
18943     "\\D",
18944     "[:alpha:]",
18945     "[:^alpha:]",
18946     "[:lower:]",
18947     "[:^lower:]",
18948     "[:upper:]",
18949     "[:^upper:]",
18950     "[:punct:]",
18951     "[:^punct:]",
18952     "[:print:]",
18953     "[:^print:]",
18954     "[:alnum:]",
18955     "[:^alnum:]",
18956     "[:graph:]",
18957     "[:^graph:]",
18958     "[:cased:]",
18959     "[:^cased:]",
18960     "\\s",
18961     "\\S",
18962     "[:blank:]",
18963     "[:^blank:]",
18964     "[:xdigit:]",
18965     "[:^xdigit:]",
18966     "[:cntrl:]",
18967     "[:^cntrl:]",
18968     "[:ascii:]",
18969     "[:^ascii:]",
18970     "\\v",
18971     "\\V"
18972 };
18973 #endif
18974
18975 /*
18976 - regprop - printable representation of opcode, with run time support
18977 */
18978
18979 void
18980 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
18981 {
18982 #ifdef DEBUGGING
18983     int k;
18984     RXi_GET_DECL(prog,progi);
18985     GET_RE_DEBUG_FLAGS_DECL;
18986
18987     PERL_ARGS_ASSERT_REGPROP;
18988
18989     SvPVCLEAR(sv);
18990
18991     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
18992         /* It would be nice to FAIL() here, but this may be called from
18993            regexec.c, and it would be hard to supply pRExC_state. */
18994         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
18995                                               (int)OP(o), (int)REGNODE_MAX);
18996     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
18997
18998     k = PL_regkind[OP(o)];
18999
19000     if (k == EXACT) {
19001         sv_catpvs(sv, " ");
19002         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
19003          * is a crude hack but it may be the best for now since
19004          * we have no flag "this EXACTish node was UTF-8"
19005          * --jhi */
19006         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
19007                   PERL_PV_ESCAPE_UNI_DETECT |
19008                   PERL_PV_ESCAPE_NONASCII   |
19009                   PERL_PV_PRETTY_ELLIPSES   |
19010                   PERL_PV_PRETTY_LTGT       |
19011                   PERL_PV_PRETTY_NOCLEAR
19012                   );
19013     } else if (k == TRIE) {
19014         /* print the details of the trie in dumpuntil instead, as
19015          * progi->data isn't available here */
19016         const char op = OP(o);
19017         const U32 n = ARG(o);
19018         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
19019                (reg_ac_data *)progi->data->data[n] :
19020                NULL;
19021         const reg_trie_data * const trie
19022             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
19023
19024         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
19025         DEBUG_TRIE_COMPILE_r({
19026           if (trie->jump)
19027             sv_catpvs(sv, "(JUMP)");
19028           Perl_sv_catpvf(aTHX_ sv,
19029             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
19030             (UV)trie->startstate,
19031             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
19032             (UV)trie->wordcount,
19033             (UV)trie->minlen,
19034             (UV)trie->maxlen,
19035             (UV)TRIE_CHARCOUNT(trie),
19036             (UV)trie->uniquecharcount
19037           );
19038         });
19039         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
19040             sv_catpvs(sv, "[");
19041             (void) put_charclass_bitmap_innards(sv,
19042                                                 ((IS_ANYOF_TRIE(op))
19043                                                  ? ANYOF_BITMAP(o)
19044                                                  : TRIE_BITMAP(trie)),
19045                                                 NULL,
19046                                                 NULL,
19047                                                 NULL,
19048                                                 FALSE
19049                                                );
19050             sv_catpvs(sv, "]");
19051         }
19052     } else if (k == CURLY) {
19053         U32 lo = ARG1(o), hi = ARG2(o);
19054         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
19055             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
19056         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
19057         if (hi == REG_INFTY)
19058             sv_catpvs(sv, "INFTY");
19059         else
19060             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
19061         sv_catpvs(sv, "}");
19062     }
19063     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
19064         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
19065     else if (k == REF || k == OPEN || k == CLOSE
19066              || k == GROUPP || OP(o)==ACCEPT)
19067     {
19068         AV *name_list= NULL;
19069         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
19070         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
19071         if ( RXp_PAREN_NAMES(prog) ) {
19072             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19073         } else if ( pRExC_state ) {
19074             name_list= RExC_paren_name_list;
19075         }
19076         if (name_list) {
19077             if ( k != REF || (OP(o) < NREF)) {
19078                 SV **name= av_fetch(name_list, parno, 0 );
19079                 if (name)
19080                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19081             }
19082             else {
19083                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
19084                 I32 *nums=(I32*)SvPVX(sv_dat);
19085                 SV **name= av_fetch(name_list, nums[0], 0 );
19086                 I32 n;
19087                 if (name) {
19088                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
19089                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
19090                                     (n ? "," : ""), (IV)nums[n]);
19091                     }
19092                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19093                 }
19094             }
19095         }
19096         if ( k == REF && reginfo) {
19097             U32 n = ARG(o);  /* which paren pair */
19098             I32 ln = prog->offs[n].start;
19099             if (prog->lastparen < n || ln == -1)
19100                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
19101             else if (ln == prog->offs[n].end)
19102                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
19103             else {
19104                 const char *s = reginfo->strbeg + ln;
19105                 Perl_sv_catpvf(aTHX_ sv, ": ");
19106                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
19107                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
19108             }
19109         }
19110     } else if (k == GOSUB) {
19111         AV *name_list= NULL;
19112         if ( RXp_PAREN_NAMES(prog) ) {
19113             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19114         } else if ( pRExC_state ) {
19115             name_list= RExC_paren_name_list;
19116         }
19117
19118         /* Paren and offset */
19119         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
19120                 (int)((o + (int)ARG2L(o)) - progi->program) );
19121         if (name_list) {
19122             SV **name= av_fetch(name_list, ARG(o), 0 );
19123             if (name)
19124                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19125         }
19126     }
19127     else if (k == LOGICAL)
19128         /* 2: embedded, otherwise 1 */
19129         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
19130     else if (k == ANYOF) {
19131         const U8 flags = ANYOF_FLAGS(o);
19132         bool do_sep = FALSE;    /* Do we need to separate various components of
19133                                    the output? */
19134         /* Set if there is still an unresolved user-defined property */
19135         SV *unresolved                = NULL;
19136
19137         /* Things that are ignored except when the runtime locale is UTF-8 */
19138         SV *only_utf8_locale_invlist = NULL;
19139
19140         /* Code points that don't fit in the bitmap */
19141         SV *nonbitmap_invlist = NULL;
19142
19143         /* And things that aren't in the bitmap, but are small enough to be */
19144         SV* bitmap_range_not_in_bitmap = NULL;
19145
19146         const bool inverted = flags & ANYOF_INVERT;
19147
19148         if (OP(o) == ANYOFL) {
19149             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
19150                 sv_catpvs(sv, "{utf8-locale-reqd}");
19151             }
19152             if (flags & ANYOFL_FOLD) {
19153                 sv_catpvs(sv, "{i}");
19154             }
19155         }
19156
19157         /* If there is stuff outside the bitmap, get it */
19158         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
19159             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
19160                                                 &unresolved,
19161                                                 &only_utf8_locale_invlist,
19162                                                 &nonbitmap_invlist);
19163             /* The non-bitmap data may contain stuff that could fit in the
19164              * bitmap.  This could come from a user-defined property being
19165              * finally resolved when this call was done; or much more likely
19166              * because there are matches that require UTF-8 to be valid, and so
19167              * aren't in the bitmap.  This is teased apart later */
19168             _invlist_intersection(nonbitmap_invlist,
19169                                   PL_InBitmap,
19170                                   &bitmap_range_not_in_bitmap);
19171             /* Leave just the things that don't fit into the bitmap */
19172             _invlist_subtract(nonbitmap_invlist,
19173                               PL_InBitmap,
19174                               &nonbitmap_invlist);
19175         }
19176
19177         /* Obey this flag to add all above-the-bitmap code points */
19178         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
19179             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
19180                                                       NUM_ANYOF_CODE_POINTS,
19181                                                       UV_MAX);
19182         }
19183
19184         /* Ready to start outputting.  First, the initial left bracket */
19185         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19186
19187         /* Then all the things that could fit in the bitmap */
19188         do_sep = put_charclass_bitmap_innards(sv,
19189                                               ANYOF_BITMAP(o),
19190                                               bitmap_range_not_in_bitmap,
19191                                               only_utf8_locale_invlist,
19192                                               o,
19193
19194                                               /* Can't try inverting for a
19195                                                * better display if there are
19196                                                * things that haven't been
19197                                                * resolved */
19198                                               unresolved != NULL);
19199         SvREFCNT_dec(bitmap_range_not_in_bitmap);
19200
19201         /* If there are user-defined properties which haven't been defined yet,
19202          * output them.  If the result is not to be inverted, it is clearest to
19203          * output them in a separate [] from the bitmap range stuff.  If the
19204          * result is to be complemented, we have to show everything in one [],
19205          * as the inversion applies to the whole thing.  Use {braces} to
19206          * separate them from anything in the bitmap and anything above the
19207          * bitmap. */
19208         if (unresolved) {
19209             if (inverted) {
19210                 if (! do_sep) { /* If didn't output anything in the bitmap */
19211                     sv_catpvs(sv, "^");
19212                 }
19213                 sv_catpvs(sv, "{");
19214             }
19215             else if (do_sep) {
19216                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19217             }
19218             sv_catsv(sv, unresolved);
19219             if (inverted) {
19220                 sv_catpvs(sv, "}");
19221             }
19222             do_sep = ! inverted;
19223         }
19224
19225         /* And, finally, add the above-the-bitmap stuff */
19226         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
19227             SV* contents;
19228
19229             /* See if truncation size is overridden */
19230             const STRLEN dump_len = (PL_dump_re_max_len)
19231                                     ? PL_dump_re_max_len
19232                                     : 256;
19233
19234             /* This is output in a separate [] */
19235             if (do_sep) {
19236                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19237             }
19238
19239             /* And, for easy of understanding, it is shown in the
19240              * uncomplemented form if possible.  The one exception being if
19241              * there are unresolved items, where the inversion has to be
19242              * delayed until runtime */
19243             if (inverted && ! unresolved) {
19244                 _invlist_invert(nonbitmap_invlist);
19245                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
19246             }
19247
19248             contents = invlist_contents(nonbitmap_invlist,
19249                                         FALSE /* output suitable for catsv */
19250                                        );
19251
19252             /* If the output is shorter than the permissible maximum, just do it. */
19253             if (SvCUR(contents) <= dump_len) {
19254                 sv_catsv(sv, contents);
19255             }
19256             else {
19257                 const char * contents_string = SvPVX(contents);
19258                 STRLEN i = dump_len;
19259
19260                 /* Otherwise, start at the permissible max and work back to the
19261                  * first break possibility */
19262                 while (i > 0 && contents_string[i] != ' ') {
19263                     i--;
19264                 }
19265                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
19266                                        find a legal break */
19267                     i = dump_len;
19268                 }
19269
19270                 sv_catpvn(sv, contents_string, i);
19271                 sv_catpvs(sv, "...");
19272             }
19273
19274             SvREFCNT_dec_NN(contents);
19275             SvREFCNT_dec_NN(nonbitmap_invlist);
19276         }
19277
19278         /* And finally the matching, closing ']' */
19279         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19280
19281         SvREFCNT_dec(unresolved);
19282     }
19283     else if (k == POSIXD || k == NPOSIXD) {
19284         U8 index = FLAGS(o) * 2;
19285         if (index < C_ARRAY_LENGTH(anyofs)) {
19286             if (*anyofs[index] != '[')  {
19287                 sv_catpv(sv, "[");
19288             }
19289             sv_catpv(sv, anyofs[index]);
19290             if (*anyofs[index] != '[')  {
19291                 sv_catpv(sv, "]");
19292             }
19293         }
19294         else {
19295             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
19296         }
19297     }
19298     else if (k == BOUND || k == NBOUND) {
19299         /* Must be synced with order of 'bound_type' in regcomp.h */
19300         const char * const bounds[] = {
19301             "",      /* Traditional */
19302             "{gcb}",
19303             "{lb}",
19304             "{sb}",
19305             "{wb}"
19306         };
19307         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
19308         sv_catpv(sv, bounds[FLAGS(o)]);
19309     }
19310     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
19311         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
19312     else if (OP(o) == SBOL)
19313         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
19314
19315     /* add on the verb argument if there is one */
19316     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
19317         Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
19318                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
19319     }
19320 #else
19321     PERL_UNUSED_CONTEXT;
19322     PERL_UNUSED_ARG(sv);
19323     PERL_UNUSED_ARG(o);
19324     PERL_UNUSED_ARG(prog);
19325     PERL_UNUSED_ARG(reginfo);
19326     PERL_UNUSED_ARG(pRExC_state);
19327 #endif  /* DEBUGGING */
19328 }
19329
19330
19331
19332 SV *
19333 Perl_re_intuit_string(pTHX_ REGEXP * const r)
19334 {                               /* Assume that RE_INTUIT is set */
19335     struct regexp *const prog = ReANY(r);
19336     GET_RE_DEBUG_FLAGS_DECL;
19337
19338     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
19339     PERL_UNUSED_CONTEXT;
19340
19341     DEBUG_COMPILE_r(
19342         {
19343             const char * const s = SvPV_nolen_const(RX_UTF8(r)
19344                       ? prog->check_utf8 : prog->check_substr);
19345
19346             if (!PL_colorset) reginitcolors();
19347             Perl_re_printf( aTHX_
19348                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
19349                       PL_colors[4],
19350                       RX_UTF8(r) ? "utf8 " : "",
19351                       PL_colors[5],PL_colors[0],
19352                       s,
19353                       PL_colors[1],
19354                       (strlen(s) > 60 ? "..." : ""));
19355         } );
19356
19357     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
19358     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
19359 }
19360
19361 /*
19362    pregfree()
19363
19364    handles refcounting and freeing the perl core regexp structure. When
19365    it is necessary to actually free the structure the first thing it
19366    does is call the 'free' method of the regexp_engine associated to
19367    the regexp, allowing the handling of the void *pprivate; member
19368    first. (This routine is not overridable by extensions, which is why
19369    the extensions free is called first.)
19370
19371    See regdupe and regdupe_internal if you change anything here.
19372 */
19373 #ifndef PERL_IN_XSUB_RE
19374 void
19375 Perl_pregfree(pTHX_ REGEXP *r)
19376 {
19377     SvREFCNT_dec(r);
19378 }
19379
19380 void
19381 Perl_pregfree2(pTHX_ REGEXP *rx)
19382 {
19383     struct regexp *const r = ReANY(rx);
19384     GET_RE_DEBUG_FLAGS_DECL;
19385
19386     PERL_ARGS_ASSERT_PREGFREE2;
19387
19388     if (r->mother_re) {
19389         ReREFCNT_dec(r->mother_re);
19390     } else {
19391         CALLREGFREE_PVT(rx); /* free the private data */
19392         SvREFCNT_dec(RXp_PAREN_NAMES(r));
19393         Safefree(r->xpv_len_u.xpvlenu_pv);
19394     }
19395     if (r->substrs) {
19396         SvREFCNT_dec(r->anchored_substr);
19397         SvREFCNT_dec(r->anchored_utf8);
19398         SvREFCNT_dec(r->float_substr);
19399         SvREFCNT_dec(r->float_utf8);
19400         Safefree(r->substrs);
19401     }
19402     RX_MATCH_COPY_FREE(rx);
19403 #ifdef PERL_ANY_COW
19404     SvREFCNT_dec(r->saved_copy);
19405 #endif
19406     Safefree(r->offs);
19407     SvREFCNT_dec(r->qr_anoncv);
19408     if (r->recurse_locinput)
19409         Safefree(r->recurse_locinput);
19410     rx->sv_u.svu_rx = 0;
19411 }
19412
19413 /*  reg_temp_copy()
19414
19415     This is a hacky workaround to the structural issue of match results
19416     being stored in the regexp structure which is in turn stored in
19417     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
19418     could be PL_curpm in multiple contexts, and could require multiple
19419     result sets being associated with the pattern simultaneously, such
19420     as when doing a recursive match with (??{$qr})
19421
19422     The solution is to make a lightweight copy of the regexp structure
19423     when a qr// is returned from the code executed by (??{$qr}) this
19424     lightweight copy doesn't actually own any of its data except for
19425     the starp/end and the actual regexp structure itself.
19426
19427 */
19428
19429
19430 REGEXP *
19431 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
19432 {
19433     struct regexp *ret;
19434     struct regexp *const r = ReANY(rx);
19435     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
19436
19437     PERL_ARGS_ASSERT_REG_TEMP_COPY;
19438
19439     if (!ret_x)
19440         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
19441     else {
19442         SvOK_off((SV *)ret_x);
19443         if (islv) {
19444             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
19445                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
19446                made both spots point to the same regexp body.) */
19447             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
19448             assert(!SvPVX(ret_x));
19449             ret_x->sv_u.svu_rx = temp->sv_any;
19450             temp->sv_any = NULL;
19451             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
19452             SvREFCNT_dec_NN(temp);
19453             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
19454                ing below will not set it. */
19455             SvCUR_set(ret_x, SvCUR(rx));
19456         }
19457     }
19458     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
19459        sv_force_normal(sv) is called.  */
19460     SvFAKE_on(ret_x);
19461     ret = ReANY(ret_x);
19462
19463     SvFLAGS(ret_x) |= SvUTF8(rx);
19464     /* We share the same string buffer as the original regexp, on which we
19465        hold a reference count, incremented when mother_re is set below.
19466        The string pointer is copied here, being part of the regexp struct.
19467      */
19468     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
19469            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
19470     if (r->offs) {
19471         const I32 npar = r->nparens+1;
19472         Newx(ret->offs, npar, regexp_paren_pair);
19473         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19474     }
19475     if (r->substrs) {
19476         Newx(ret->substrs, 1, struct reg_substr_data);
19477         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19478
19479         SvREFCNT_inc_void(ret->anchored_substr);
19480         SvREFCNT_inc_void(ret->anchored_utf8);
19481         SvREFCNT_inc_void(ret->float_substr);
19482         SvREFCNT_inc_void(ret->float_utf8);
19483
19484         /* check_substr and check_utf8, if non-NULL, point to either their
19485            anchored or float namesakes, and don't hold a second reference.  */
19486     }
19487     RX_MATCH_COPIED_off(ret_x);
19488 #ifdef PERL_ANY_COW
19489     ret->saved_copy = NULL;
19490 #endif
19491     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
19492     SvREFCNT_inc_void(ret->qr_anoncv);
19493     if (r->recurse_locinput)
19494         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19495
19496     return ret_x;
19497 }
19498 #endif
19499
19500 /* regfree_internal()
19501
19502    Free the private data in a regexp. This is overloadable by
19503    extensions. Perl takes care of the regexp structure in pregfree(),
19504    this covers the *pprivate pointer which technically perl doesn't
19505    know about, however of course we have to handle the
19506    regexp_internal structure when no extension is in use.
19507
19508    Note this is called before freeing anything in the regexp
19509    structure.
19510  */
19511
19512 void
19513 Perl_regfree_internal(pTHX_ REGEXP * const rx)
19514 {
19515     struct regexp *const r = ReANY(rx);
19516     RXi_GET_DECL(r,ri);
19517     GET_RE_DEBUG_FLAGS_DECL;
19518
19519     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
19520
19521     DEBUG_COMPILE_r({
19522         if (!PL_colorset)
19523             reginitcolors();
19524         {
19525             SV *dsv= sv_newmortal();
19526             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
19527                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
19528             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
19529                 PL_colors[4],PL_colors[5],s);
19530         }
19531     });
19532 #ifdef RE_TRACK_PATTERN_OFFSETS
19533     if (ri->u.offsets)
19534         Safefree(ri->u.offsets);             /* 20010421 MJD */
19535 #endif
19536     if (ri->code_blocks)
19537         S_free_codeblocks(aTHX_ ri->code_blocks);
19538
19539     if (ri->data) {
19540         int n = ri->data->count;
19541
19542         while (--n >= 0) {
19543           /* If you add a ->what type here, update the comment in regcomp.h */
19544             switch (ri->data->what[n]) {
19545             case 'a':
19546             case 'r':
19547             case 's':
19548             case 'S':
19549             case 'u':
19550                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
19551                 break;
19552             case 'f':
19553                 Safefree(ri->data->data[n]);
19554                 break;
19555             case 'l':
19556             case 'L':
19557                 break;
19558             case 'T':
19559                 { /* Aho Corasick add-on structure for a trie node.
19560                      Used in stclass optimization only */
19561                     U32 refcount;
19562                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
19563 #ifdef USE_ITHREADS
19564                     dVAR;
19565 #endif
19566                     OP_REFCNT_LOCK;
19567                     refcount = --aho->refcount;
19568                     OP_REFCNT_UNLOCK;
19569                     if ( !refcount ) {
19570                         PerlMemShared_free(aho->states);
19571                         PerlMemShared_free(aho->fail);
19572                          /* do this last!!!! */
19573                         PerlMemShared_free(ri->data->data[n]);
19574                         /* we should only ever get called once, so
19575                          * assert as much, and also guard the free
19576                          * which /might/ happen twice. At the least
19577                          * it will make code anlyzers happy and it
19578                          * doesn't cost much. - Yves */
19579                         assert(ri->regstclass);
19580                         if (ri->regstclass) {
19581                             PerlMemShared_free(ri->regstclass);
19582                             ri->regstclass = 0;
19583                         }
19584                     }
19585                 }
19586                 break;
19587             case 't':
19588                 {
19589                     /* trie structure. */
19590                     U32 refcount;
19591                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
19592 #ifdef USE_ITHREADS
19593                     dVAR;
19594 #endif
19595                     OP_REFCNT_LOCK;
19596                     refcount = --trie->refcount;
19597                     OP_REFCNT_UNLOCK;
19598                     if ( !refcount ) {
19599                         PerlMemShared_free(trie->charmap);
19600                         PerlMemShared_free(trie->states);
19601                         PerlMemShared_free(trie->trans);
19602                         if (trie->bitmap)
19603                             PerlMemShared_free(trie->bitmap);
19604                         if (trie->jump)
19605                             PerlMemShared_free(trie->jump);
19606                         PerlMemShared_free(trie->wordinfo);
19607                         /* do this last!!!! */
19608                         PerlMemShared_free(ri->data->data[n]);
19609                     }
19610                 }
19611                 break;
19612             default:
19613                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
19614                                                     ri->data->what[n]);
19615             }
19616         }
19617         Safefree(ri->data->what);
19618         Safefree(ri->data);
19619     }
19620
19621     Safefree(ri);
19622 }
19623
19624 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
19625 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
19626 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
19627
19628 /*
19629    re_dup_guts - duplicate a regexp.
19630
19631    This routine is expected to clone a given regexp structure. It is only
19632    compiled under USE_ITHREADS.
19633
19634    After all of the core data stored in struct regexp is duplicated
19635    the regexp_engine.dupe method is used to copy any private data
19636    stored in the *pprivate pointer. This allows extensions to handle
19637    any duplication it needs to do.
19638
19639    See pregfree() and regfree_internal() if you change anything here.
19640 */
19641 #if defined(USE_ITHREADS)
19642 #ifndef PERL_IN_XSUB_RE
19643 void
19644 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
19645 {
19646     dVAR;
19647     I32 npar;
19648     const struct regexp *r = ReANY(sstr);
19649     struct regexp *ret = ReANY(dstr);
19650
19651     PERL_ARGS_ASSERT_RE_DUP_GUTS;
19652
19653     npar = r->nparens+1;
19654     Newx(ret->offs, npar, regexp_paren_pair);
19655     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19656
19657     if (ret->substrs) {
19658         /* Do it this way to avoid reading from *r after the StructCopy().
19659            That way, if any of the sv_dup_inc()s dislodge *r from the L1
19660            cache, it doesn't matter.  */
19661         const bool anchored = r->check_substr
19662             ? r->check_substr == r->anchored_substr
19663             : r->check_utf8 == r->anchored_utf8;
19664         Newx(ret->substrs, 1, struct reg_substr_data);
19665         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19666
19667         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
19668         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
19669         ret->float_substr = sv_dup_inc(ret->float_substr, param);
19670         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
19671
19672         /* check_substr and check_utf8, if non-NULL, point to either their
19673            anchored or float namesakes, and don't hold a second reference.  */
19674
19675         if (ret->check_substr) {
19676             if (anchored) {
19677                 assert(r->check_utf8 == r->anchored_utf8);
19678                 ret->check_substr = ret->anchored_substr;
19679                 ret->check_utf8 = ret->anchored_utf8;
19680             } else {
19681                 assert(r->check_substr == r->float_substr);
19682                 assert(r->check_utf8 == r->float_utf8);
19683                 ret->check_substr = ret->float_substr;
19684                 ret->check_utf8 = ret->float_utf8;
19685             }
19686         } else if (ret->check_utf8) {
19687             if (anchored) {
19688                 ret->check_utf8 = ret->anchored_utf8;
19689             } else {
19690                 ret->check_utf8 = ret->float_utf8;
19691             }
19692         }
19693     }
19694
19695     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
19696     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
19697     if (r->recurse_locinput)
19698         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19699
19700     if (ret->pprivate)
19701         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
19702
19703     if (RX_MATCH_COPIED(dstr))
19704         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
19705     else
19706         ret->subbeg = NULL;
19707 #ifdef PERL_ANY_COW
19708     ret->saved_copy = NULL;
19709 #endif
19710
19711     /* Whether mother_re be set or no, we need to copy the string.  We
19712        cannot refrain from copying it when the storage points directly to
19713        our mother regexp, because that's
19714                1: a buffer in a different thread
19715                2: something we no longer hold a reference on
19716                so we need to copy it locally.  */
19717     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
19718     ret->mother_re   = NULL;
19719 }
19720 #endif /* PERL_IN_XSUB_RE */
19721
19722 /*
19723    regdupe_internal()
19724
19725    This is the internal complement to regdupe() which is used to copy
19726    the structure pointed to by the *pprivate pointer in the regexp.
19727    This is the core version of the extension overridable cloning hook.
19728    The regexp structure being duplicated will be copied by perl prior
19729    to this and will be provided as the regexp *r argument, however
19730    with the /old/ structures pprivate pointer value. Thus this routine
19731    may override any copying normally done by perl.
19732
19733    It returns a pointer to the new regexp_internal structure.
19734 */
19735
19736 void *
19737 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
19738 {
19739     dVAR;
19740     struct regexp *const r = ReANY(rx);
19741     regexp_internal *reti;
19742     int len;
19743     RXi_GET_DECL(r,ri);
19744
19745     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
19746
19747     len = ProgLen(ri);
19748
19749     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
19750           char, regexp_internal);
19751     Copy(ri->program, reti->program, len+1, regnode);
19752
19753
19754     if (ri->code_blocks) {
19755         int n;
19756         Newx(reti->code_blocks, 1, struct reg_code_blocks);
19757         Newx(reti->code_blocks->cb, ri->code_blocks->count,
19758                     struct reg_code_block);
19759         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
19760              ri->code_blocks->count, struct reg_code_block);
19761         for (n = 0; n < ri->code_blocks->count; n++)
19762              reti->code_blocks->cb[n].src_regex = (REGEXP*)
19763                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
19764         reti->code_blocks->count = ri->code_blocks->count;
19765         reti->code_blocks->refcnt = 1;
19766     }
19767     else
19768         reti->code_blocks = NULL;
19769
19770     reti->regstclass = NULL;
19771
19772     if (ri->data) {
19773         struct reg_data *d;
19774         const int count = ri->data->count;
19775         int i;
19776
19777         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
19778                 char, struct reg_data);
19779         Newx(d->what, count, U8);
19780
19781         d->count = count;
19782         for (i = 0; i < count; i++) {
19783             d->what[i] = ri->data->what[i];
19784             switch (d->what[i]) {
19785                 /* see also regcomp.h and regfree_internal() */
19786             case 'a': /* actually an AV, but the dup function is identical.  */
19787             case 'r':
19788             case 's':
19789             case 'S':
19790             case 'u': /* actually an HV, but the dup function is identical.  */
19791                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
19792                 break;
19793             case 'f':
19794                 /* This is cheating. */
19795                 Newx(d->data[i], 1, regnode_ssc);
19796                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
19797                 reti->regstclass = (regnode*)d->data[i];
19798                 break;
19799             case 'T':
19800                 /* Trie stclasses are readonly and can thus be shared
19801                  * without duplication. We free the stclass in pregfree
19802                  * when the corresponding reg_ac_data struct is freed.
19803                  */
19804                 reti->regstclass= ri->regstclass;
19805                 /* FALLTHROUGH */
19806             case 't':
19807                 OP_REFCNT_LOCK;
19808                 ((reg_trie_data*)ri->data->data[i])->refcount++;
19809                 OP_REFCNT_UNLOCK;
19810                 /* FALLTHROUGH */
19811             case 'l':
19812             case 'L':
19813                 d->data[i] = ri->data->data[i];
19814                 break;
19815             default:
19816                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
19817                                                            ri->data->what[i]);
19818             }
19819         }
19820
19821         reti->data = d;
19822     }
19823     else
19824         reti->data = NULL;
19825
19826     reti->name_list_idx = ri->name_list_idx;
19827
19828 #ifdef RE_TRACK_PATTERN_OFFSETS
19829     if (ri->u.offsets) {
19830         Newx(reti->u.offsets, 2*len+1, U32);
19831         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
19832     }
19833 #else
19834     SetProgLen(reti,len);
19835 #endif
19836
19837     return (void*)reti;
19838 }
19839
19840 #endif    /* USE_ITHREADS */
19841
19842 #ifndef PERL_IN_XSUB_RE
19843
19844 /*
19845  - regnext - dig the "next" pointer out of a node
19846  */
19847 regnode *
19848 Perl_regnext(pTHX_ regnode *p)
19849 {
19850     I32 offset;
19851
19852     if (!p)
19853         return(NULL);
19854
19855     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
19856         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19857                                                 (int)OP(p), (int)REGNODE_MAX);
19858     }
19859
19860     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
19861     if (offset == 0)
19862         return(NULL);
19863
19864     return(p+offset);
19865 }
19866 #endif
19867
19868 STATIC void
19869 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
19870 {
19871     va_list args;
19872     STRLEN l1 = strlen(pat1);
19873     STRLEN l2 = strlen(pat2);
19874     char buf[512];
19875     SV *msv;
19876     const char *message;
19877
19878     PERL_ARGS_ASSERT_RE_CROAK2;
19879
19880     if (l1 > 510)
19881         l1 = 510;
19882     if (l1 + l2 > 510)
19883         l2 = 510 - l1;
19884     Copy(pat1, buf, l1 , char);
19885     Copy(pat2, buf + l1, l2 , char);
19886     buf[l1 + l2] = '\n';
19887     buf[l1 + l2 + 1] = '\0';
19888     va_start(args, pat2);
19889     msv = vmess(buf, &args);
19890     va_end(args);
19891     message = SvPV_const(msv,l1);
19892     if (l1 > 512)
19893         l1 = 512;
19894     Copy(message, buf, l1 , char);
19895     /* l1-1 to avoid \n */
19896     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
19897 }
19898
19899 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
19900
19901 #ifndef PERL_IN_XSUB_RE
19902 void
19903 Perl_save_re_context(pTHX)
19904 {
19905     I32 nparens = -1;
19906     I32 i;
19907
19908     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
19909
19910     if (PL_curpm) {
19911         const REGEXP * const rx = PM_GETRE(PL_curpm);
19912         if (rx)
19913             nparens = RX_NPARENS(rx);
19914     }
19915
19916     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
19917      * that PL_curpm will be null, but that utf8.pm and the modules it
19918      * loads will only use $1..$3.
19919      * The t/porting/re_context.t test file checks this assumption.
19920      */
19921     if (nparens == -1)
19922         nparens = 3;
19923
19924     for (i = 1; i <= nparens; i++) {
19925         char digits[TYPE_CHARS(long)];
19926         const STRLEN len = my_snprintf(digits, sizeof(digits),
19927                                        "%lu", (long)i);
19928         GV *const *const gvp
19929             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
19930
19931         if (gvp) {
19932             GV * const gv = *gvp;
19933             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
19934                 save_scalar(gv);
19935         }
19936     }
19937 }
19938 #endif
19939
19940 #ifdef DEBUGGING
19941
19942 STATIC void
19943 S_put_code_point(pTHX_ SV *sv, UV c)
19944 {
19945     PERL_ARGS_ASSERT_PUT_CODE_POINT;
19946
19947     if (c > 255) {
19948         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
19949     }
19950     else if (isPRINT(c)) {
19951         const char string = (char) c;
19952
19953         /* We use {phrase} as metanotation in the class, so also escape literal
19954          * braces */
19955         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
19956             sv_catpvs(sv, "\\");
19957         sv_catpvn(sv, &string, 1);
19958     }
19959     else if (isMNEMONIC_CNTRL(c)) {
19960         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
19961     }
19962     else {
19963         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
19964     }
19965 }
19966
19967 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
19968
19969 STATIC void
19970 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
19971 {
19972     /* Appends to 'sv' a displayable version of the range of code points from
19973      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
19974      * that have them, when they occur at the beginning or end of the range.
19975      * It uses hex to output the remaining code points, unless 'allow_literals'
19976      * is true, in which case the printable ASCII ones are output as-is (though
19977      * some of these will be escaped by put_code_point()).
19978      *
19979      * NOTE:  This is designed only for printing ranges of code points that fit
19980      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
19981      */
19982
19983     const unsigned int min_range_count = 3;
19984
19985     assert(start <= end);
19986
19987     PERL_ARGS_ASSERT_PUT_RANGE;
19988
19989     while (start <= end) {
19990         UV this_end;
19991         const char * format;
19992
19993         if (end - start < min_range_count) {
19994
19995             /* Output chars individually when they occur in short ranges */
19996             for (; start <= end; start++) {
19997                 put_code_point(sv, start);
19998             }
19999             break;
20000         }
20001
20002         /* If permitted by the input options, and there is a possibility that
20003          * this range contains a printable literal, look to see if there is
20004          * one. */
20005         if (allow_literals && start <= MAX_PRINT_A) {
20006
20007             /* If the character at the beginning of the range isn't an ASCII
20008              * printable, effectively split the range into two parts:
20009              *  1) the portion before the first such printable,
20010              *  2) the rest
20011              * and output them separately. */
20012             if (! isPRINT_A(start)) {
20013                 UV temp_end = start + 1;
20014
20015                 /* There is no point looking beyond the final possible
20016                  * printable, in MAX_PRINT_A */
20017                 UV max = MIN(end, MAX_PRINT_A);
20018
20019                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
20020                     temp_end++;
20021                 }
20022
20023                 /* Here, temp_end points to one beyond the first printable if
20024                  * found, or to one beyond 'max' if not.  If none found, make
20025                  * sure that we use the entire range */
20026                 if (temp_end > MAX_PRINT_A) {
20027                     temp_end = end + 1;
20028                 }
20029
20030                 /* Output the first part of the split range: the part that
20031                  * doesn't have printables, with the parameter set to not look
20032                  * for literals (otherwise we would infinitely recurse) */
20033                 put_range(sv, start, temp_end - 1, FALSE);
20034
20035                 /* The 2nd part of the range (if any) starts here. */
20036                 start = temp_end;
20037
20038                 /* We do a continue, instead of dropping down, because even if
20039                  * the 2nd part is non-empty, it could be so short that we want
20040                  * to output it as individual characters, as tested for at the
20041                  * top of this loop.  */
20042                 continue;
20043             }
20044
20045             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
20046              * output a sub-range of just the digits or letters, then process
20047              * the remaining portion as usual. */
20048             if (isALPHANUMERIC_A(start)) {
20049                 UV mask = (isDIGIT_A(start))
20050                            ? _CC_DIGIT
20051                              : isUPPER_A(start)
20052                                ? _CC_UPPER
20053                                : _CC_LOWER;
20054                 UV temp_end = start + 1;
20055
20056                 /* Find the end of the sub-range that includes just the
20057                  * characters in the same class as the first character in it */
20058                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
20059                     temp_end++;
20060                 }
20061                 temp_end--;
20062
20063                 /* For short ranges, don't duplicate the code above to output
20064                  * them; just call recursively */
20065                 if (temp_end - start < min_range_count) {
20066                     put_range(sv, start, temp_end, FALSE);
20067                 }
20068                 else {  /* Output as a range */
20069                     put_code_point(sv, start);
20070                     sv_catpvs(sv, "-");
20071                     put_code_point(sv, temp_end);
20072                 }
20073                 start = temp_end + 1;
20074                 continue;
20075             }
20076
20077             /* We output any other printables as individual characters */
20078             if (isPUNCT_A(start) || isSPACE_A(start)) {
20079                 while (start <= end && (isPUNCT_A(start)
20080                                         || isSPACE_A(start)))
20081                 {
20082                     put_code_point(sv, start);
20083                     start++;
20084                 }
20085                 continue;
20086             }
20087         } /* End of looking for literals */
20088
20089         /* Here is not to output as a literal.  Some control characters have
20090          * mnemonic names.  Split off any of those at the beginning and end of
20091          * the range to print mnemonically.  It isn't possible for many of
20092          * these to be in a row, so this won't overwhelm with output */
20093         if (   start <= end
20094             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
20095         {
20096             while (isMNEMONIC_CNTRL(start) && start <= end) {
20097                 put_code_point(sv, start);
20098                 start++;
20099             }
20100
20101             /* If this didn't take care of the whole range ... */
20102             if (start <= end) {
20103
20104                 /* Look backwards from the end to find the final non-mnemonic
20105                  * */
20106                 UV temp_end = end;
20107                 while (isMNEMONIC_CNTRL(temp_end)) {
20108                     temp_end--;
20109                 }
20110
20111                 /* And separately output the interior range that doesn't start
20112                  * or end with mnemonics */
20113                 put_range(sv, start, temp_end, FALSE);
20114
20115                 /* Then output the mnemonic trailing controls */
20116                 start = temp_end + 1;
20117                 while (start <= end) {
20118                     put_code_point(sv, start);
20119                     start++;
20120                 }
20121                 break;
20122             }
20123         }
20124
20125         /* As a final resort, output the range or subrange as hex. */
20126
20127         this_end = (end < NUM_ANYOF_CODE_POINTS)
20128                     ? end
20129                     : NUM_ANYOF_CODE_POINTS - 1;
20130 #if NUM_ANYOF_CODE_POINTS > 256
20131         format = (this_end < 256)
20132                  ? "\\x%02" UVXf "-\\x%02" UVXf
20133                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
20134 #else
20135         format = "\\x%02" UVXf "-\\x%02" UVXf;
20136 #endif
20137         GCC_DIAG_IGNORE(-Wformat-nonliteral);
20138         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
20139         GCC_DIAG_RESTORE;
20140         break;
20141     }
20142 }
20143
20144 STATIC void
20145 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
20146 {
20147     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
20148      * 'invlist' */
20149
20150     UV start, end;
20151     bool allow_literals = TRUE;
20152
20153     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
20154
20155     /* Generally, it is more readable if printable characters are output as
20156      * literals, but if a range (nearly) spans all of them, it's best to output
20157      * it as a single range.  This code will use a single range if all but 2
20158      * ASCII printables are in it */
20159     invlist_iterinit(invlist);
20160     while (invlist_iternext(invlist, &start, &end)) {
20161
20162         /* If the range starts beyond the final printable, it doesn't have any
20163          * in it */
20164         if (start > MAX_PRINT_A) {
20165             break;
20166         }
20167
20168         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
20169          * all but two, the range must start and end no later than 2 from
20170          * either end */
20171         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
20172             if (end > MAX_PRINT_A) {
20173                 end = MAX_PRINT_A;
20174             }
20175             if (start < ' ') {
20176                 start = ' ';
20177             }
20178             if (end - start >= MAX_PRINT_A - ' ' - 2) {
20179                 allow_literals = FALSE;
20180             }
20181             break;
20182         }
20183     }
20184     invlist_iterfinish(invlist);
20185
20186     /* Here we have figured things out.  Output each range */
20187     invlist_iterinit(invlist);
20188     while (invlist_iternext(invlist, &start, &end)) {
20189         if (start >= NUM_ANYOF_CODE_POINTS) {
20190             break;
20191         }
20192         put_range(sv, start, end, allow_literals);
20193     }
20194     invlist_iterfinish(invlist);
20195
20196     return;
20197 }
20198
20199 STATIC SV*
20200 S_put_charclass_bitmap_innards_common(pTHX_
20201         SV* invlist,            /* The bitmap */
20202         SV* posixes,            /* Under /l, things like [:word:], \S */
20203         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
20204         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
20205         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
20206         const bool invert       /* Is the result to be inverted? */
20207 )
20208 {
20209     /* Create and return an SV containing a displayable version of the bitmap
20210      * and associated information determined by the input parameters.  If the
20211      * output would have been only the inversion indicator '^', NULL is instead
20212      * returned. */
20213
20214     SV * output;
20215
20216     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
20217
20218     if (invert) {
20219         output = newSVpvs("^");
20220     }
20221     else {
20222         output = newSVpvs("");
20223     }
20224
20225     /* First, the code points in the bitmap that are unconditionally there */
20226     put_charclass_bitmap_innards_invlist(output, invlist);
20227
20228     /* Traditionally, these have been placed after the main code points */
20229     if (posixes) {
20230         sv_catsv(output, posixes);
20231     }
20232
20233     if (only_utf8 && _invlist_len(only_utf8)) {
20234         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
20235         put_charclass_bitmap_innards_invlist(output, only_utf8);
20236     }
20237
20238     if (not_utf8 && _invlist_len(not_utf8)) {
20239         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
20240         put_charclass_bitmap_innards_invlist(output, not_utf8);
20241     }
20242
20243     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
20244         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
20245         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
20246
20247         /* This is the only list in this routine that can legally contain code
20248          * points outside the bitmap range.  The call just above to
20249          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
20250          * output them here.  There's about a half-dozen possible, and none in
20251          * contiguous ranges longer than 2 */
20252         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20253             UV start, end;
20254             SV* above_bitmap = NULL;
20255
20256             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
20257
20258             invlist_iterinit(above_bitmap);
20259             while (invlist_iternext(above_bitmap, &start, &end)) {
20260                 UV i;
20261
20262                 for (i = start; i <= end; i++) {
20263                     put_code_point(output, i);
20264                 }
20265             }
20266             invlist_iterfinish(above_bitmap);
20267             SvREFCNT_dec_NN(above_bitmap);
20268         }
20269     }
20270
20271     if (invert && SvCUR(output) == 1) {
20272         return NULL;
20273     }
20274
20275     return output;
20276 }
20277
20278 STATIC bool
20279 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
20280                                      char *bitmap,
20281                                      SV *nonbitmap_invlist,
20282                                      SV *only_utf8_locale_invlist,
20283                                      const regnode * const node,
20284                                      const bool force_as_is_display)
20285 {
20286     /* Appends to 'sv' a displayable version of the innards of the bracketed
20287      * character class defined by the other arguments:
20288      *  'bitmap' points to the bitmap.
20289      *  'nonbitmap_invlist' is an inversion list of the code points that are in
20290      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
20291      *      none.  The reasons for this could be that they require some
20292      *      condition such as the target string being or not being in UTF-8
20293      *      (under /d), or because they came from a user-defined property that
20294      *      was not resolved at the time of the regex compilation (under /u)
20295      *  'only_utf8_locale_invlist' is an inversion list of the code points that
20296      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
20297      *  'node' is the regex pattern node.  It is needed only when the above two
20298      *      parameters are not null, and is passed so that this routine can
20299      *      tease apart the various reasons for them.
20300      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
20301      *      to invert things to see if that leads to a cleaner display.  If
20302      *      FALSE, this routine is free to use its judgment about doing this.
20303      *
20304      * It returns TRUE if there was actually something output.  (It may be that
20305      * the bitmap, etc is empty.)
20306      *
20307      * When called for outputting the bitmap of a non-ANYOF node, just pass the
20308      * bitmap, with the succeeding parameters set to NULL, and the final one to
20309      * FALSE.
20310      */
20311
20312     /* In general, it tries to display the 'cleanest' representation of the
20313      * innards, choosing whether to display them inverted or not, regardless of
20314      * whether the class itself is to be inverted.  However,  there are some
20315      * cases where it can't try inverting, as what actually matches isn't known
20316      * until runtime, and hence the inversion isn't either. */
20317     bool inverting_allowed = ! force_as_is_display;
20318
20319     int i;
20320     STRLEN orig_sv_cur = SvCUR(sv);
20321
20322     SV* invlist;            /* Inversion list we accumulate of code points that
20323                                are unconditionally matched */
20324     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
20325                                UTF-8 */
20326     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
20327                              */
20328     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
20329     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
20330                                        is UTF-8 */
20331
20332     SV* as_is_display;      /* The output string when we take the inputs
20333                                literally */
20334     SV* inverted_display;   /* The output string when we invert the inputs */
20335
20336     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
20337
20338     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
20339                                                    to match? */
20340     /* We are biased in favor of displaying things without them being inverted,
20341      * as that is generally easier to understand */
20342     const int bias = 5;
20343
20344     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
20345
20346     /* Start off with whatever code points are passed in.  (We clone, so we
20347      * don't change the caller's list) */
20348     if (nonbitmap_invlist) {
20349         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
20350         invlist = invlist_clone(nonbitmap_invlist);
20351     }
20352     else {  /* Worst case size is every other code point is matched */
20353         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
20354     }
20355
20356     if (flags) {
20357         if (OP(node) == ANYOFD) {
20358
20359             /* This flag indicates that the code points below 0x100 in the
20360              * nonbitmap list are precisely the ones that match only when the
20361              * target is UTF-8 (they should all be non-ASCII). */
20362             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
20363             {
20364                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
20365                 _invlist_subtract(invlist, only_utf8, &invlist);
20366             }
20367
20368             /* And this flag for matching all non-ASCII 0xFF and below */
20369             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
20370             {
20371                 not_utf8 = invlist_clone(PL_UpperLatin1);
20372             }
20373         }
20374         else if (OP(node) == ANYOFL) {
20375
20376             /* If either of these flags are set, what matches isn't
20377              * determinable except during execution, so don't know enough here
20378              * to invert */
20379             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
20380                 inverting_allowed = FALSE;
20381             }
20382
20383             /* What the posix classes match also varies at runtime, so these
20384              * will be output symbolically. */
20385             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
20386                 int i;
20387
20388                 posixes = newSVpvs("");
20389                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
20390                     if (ANYOF_POSIXL_TEST(node,i)) {
20391                         sv_catpv(posixes, anyofs[i]);
20392                     }
20393                 }
20394             }
20395         }
20396     }
20397
20398     /* Accumulate the bit map into the unconditional match list */
20399     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
20400         if (BITMAP_TEST(bitmap, i)) {
20401             int start = i++;
20402             for (; i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i); i++) {
20403                 /* empty */
20404             }
20405             invlist = _add_range_to_invlist(invlist, start, i-1);
20406         }
20407     }
20408
20409     /* Make sure that the conditional match lists don't have anything in them
20410      * that match unconditionally; otherwise the output is quite confusing.
20411      * This could happen if the code that populates these misses some
20412      * duplication. */
20413     if (only_utf8) {
20414         _invlist_subtract(only_utf8, invlist, &only_utf8);
20415     }
20416     if (not_utf8) {
20417         _invlist_subtract(not_utf8, invlist, &not_utf8);
20418     }
20419
20420     if (only_utf8_locale_invlist) {
20421
20422         /* Since this list is passed in, we have to make a copy before
20423          * modifying it */
20424         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
20425
20426         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
20427
20428         /* And, it can get really weird for us to try outputting an inverted
20429          * form of this list when it has things above the bitmap, so don't even
20430          * try */
20431         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20432             inverting_allowed = FALSE;
20433         }
20434     }
20435
20436     /* Calculate what the output would be if we take the input as-is */
20437     as_is_display = put_charclass_bitmap_innards_common(invlist,
20438                                                     posixes,
20439                                                     only_utf8,
20440                                                     not_utf8,
20441                                                     only_utf8_locale,
20442                                                     invert);
20443
20444     /* If have to take the output as-is, just do that */
20445     if (! inverting_allowed) {
20446         if (as_is_display) {
20447             sv_catsv(sv, as_is_display);
20448             SvREFCNT_dec_NN(as_is_display);
20449         }
20450     }
20451     else { /* But otherwise, create the output again on the inverted input, and
20452               use whichever version is shorter */
20453
20454         int inverted_bias, as_is_bias;
20455
20456         /* We will apply our bias to whichever of the the results doesn't have
20457          * the '^' */
20458         if (invert) {
20459             invert = FALSE;
20460             as_is_bias = bias;
20461             inverted_bias = 0;
20462         }
20463         else {
20464             invert = TRUE;
20465             as_is_bias = 0;
20466             inverted_bias = bias;
20467         }
20468
20469         /* Now invert each of the lists that contribute to the output,
20470          * excluding from the result things outside the possible range */
20471
20472         /* For the unconditional inversion list, we have to add in all the
20473          * conditional code points, so that when inverted, they will be gone
20474          * from it */
20475         _invlist_union(only_utf8, invlist, &invlist);
20476         _invlist_union(not_utf8, invlist, &invlist);
20477         _invlist_union(only_utf8_locale, invlist, &invlist);
20478         _invlist_invert(invlist);
20479         _invlist_intersection(invlist, PL_InBitmap, &invlist);
20480
20481         if (only_utf8) {
20482             _invlist_invert(only_utf8);
20483             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
20484         }
20485         else if (not_utf8) {
20486
20487             /* If a code point matches iff the target string is not in UTF-8,
20488              * then complementing the result has it not match iff not in UTF-8,
20489              * which is the same thing as matching iff it is UTF-8. */
20490             only_utf8 = not_utf8;
20491             not_utf8 = NULL;
20492         }
20493
20494         if (only_utf8_locale) {
20495             _invlist_invert(only_utf8_locale);
20496             _invlist_intersection(only_utf8_locale,
20497                                   PL_InBitmap,
20498                                   &only_utf8_locale);
20499         }
20500
20501         inverted_display = put_charclass_bitmap_innards_common(
20502                                             invlist,
20503                                             posixes,
20504                                             only_utf8,
20505                                             not_utf8,
20506                                             only_utf8_locale, invert);
20507
20508         /* Use the shortest representation, taking into account our bias
20509          * against showing it inverted */
20510         if (   inverted_display
20511             && (   ! as_is_display
20512                 || (  SvCUR(inverted_display) + inverted_bias
20513                     < SvCUR(as_is_display)    + as_is_bias)))
20514         {
20515             sv_catsv(sv, inverted_display);
20516         }
20517         else if (as_is_display) {
20518             sv_catsv(sv, as_is_display);
20519         }
20520
20521         SvREFCNT_dec(as_is_display);
20522         SvREFCNT_dec(inverted_display);
20523     }
20524
20525     SvREFCNT_dec_NN(invlist);
20526     SvREFCNT_dec(only_utf8);
20527     SvREFCNT_dec(not_utf8);
20528     SvREFCNT_dec(posixes);
20529     SvREFCNT_dec(only_utf8_locale);
20530
20531     return SvCUR(sv) > orig_sv_cur;
20532 }
20533
20534 #define CLEAR_OPTSTART                                                       \
20535     if (optstart) STMT_START {                                               \
20536         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
20537                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
20538         optstart=NULL;                                                       \
20539     } STMT_END
20540
20541 #define DUMPUNTIL(b,e)                                                       \
20542                     CLEAR_OPTSTART;                                          \
20543                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
20544
20545 STATIC const regnode *
20546 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
20547             const regnode *last, const regnode *plast,
20548             SV* sv, I32 indent, U32 depth)
20549 {
20550     U8 op = PSEUDO;     /* Arbitrary non-END op. */
20551     const regnode *next;
20552     const regnode *optstart= NULL;
20553
20554     RXi_GET_DECL(r,ri);
20555     GET_RE_DEBUG_FLAGS_DECL;
20556
20557     PERL_ARGS_ASSERT_DUMPUNTIL;
20558
20559 #ifdef DEBUG_DUMPUNTIL
20560     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
20561         last ? last-start : 0,plast ? plast-start : 0);
20562 #endif
20563
20564     if (plast && plast < last)
20565         last= plast;
20566
20567     while (PL_regkind[op] != END && (!last || node < last)) {
20568         assert(node);
20569         /* While that wasn't END last time... */
20570         NODE_ALIGN(node);
20571         op = OP(node);
20572         if (op == CLOSE || op == WHILEM)
20573             indent--;
20574         next = regnext((regnode *)node);
20575
20576         /* Where, what. */
20577         if (OP(node) == OPTIMIZED) {
20578             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
20579                 optstart = node;
20580             else
20581                 goto after_print;
20582         } else
20583             CLEAR_OPTSTART;
20584
20585         regprop(r, sv, node, NULL, NULL);
20586         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
20587                       (int)(2*indent + 1), "", SvPVX_const(sv));
20588
20589         if (OP(node) != OPTIMIZED) {
20590             if (next == NULL)           /* Next ptr. */
20591                 Perl_re_printf( aTHX_  " (0)");
20592             else if (PL_regkind[(U8)op] == BRANCH
20593                      && PL_regkind[OP(next)] != BRANCH )
20594                 Perl_re_printf( aTHX_  " (FAIL)");
20595             else
20596                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
20597             Perl_re_printf( aTHX_ "\n");
20598         }
20599
20600       after_print:
20601         if (PL_regkind[(U8)op] == BRANCHJ) {
20602             assert(next);
20603             {
20604                 const regnode *nnode = (OP(next) == LONGJMP
20605                                        ? regnext((regnode *)next)
20606                                        : next);
20607                 if (last && nnode > last)
20608                     nnode = last;
20609                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
20610             }
20611         }
20612         else if (PL_regkind[(U8)op] == BRANCH) {
20613             assert(next);
20614             DUMPUNTIL(NEXTOPER(node), next);
20615         }
20616         else if ( PL_regkind[(U8)op]  == TRIE ) {
20617             const regnode *this_trie = node;
20618             const char op = OP(node);
20619             const U32 n = ARG(node);
20620             const reg_ac_data * const ac = op>=AHOCORASICK ?
20621                (reg_ac_data *)ri->data->data[n] :
20622                NULL;
20623             const reg_trie_data * const trie =
20624                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
20625 #ifdef DEBUGGING
20626             AV *const trie_words
20627                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
20628 #endif
20629             const regnode *nextbranch= NULL;
20630             I32 word_idx;
20631             SvPVCLEAR(sv);
20632             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
20633                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
20634
20635                 Perl_re_indentf( aTHX_  "%s ",
20636                     indent+3,
20637                     elem_ptr
20638                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
20639                                 SvCUR(*elem_ptr), 60,
20640                                 PL_colors[0], PL_colors[1],
20641                                 (SvUTF8(*elem_ptr)
20642                                  ? PERL_PV_ESCAPE_UNI
20643                                  : 0)
20644                                 | PERL_PV_PRETTY_ELLIPSES
20645                                 | PERL_PV_PRETTY_LTGT
20646                             )
20647                     : "???"
20648                 );
20649                 if (trie->jump) {
20650                     U16 dist= trie->jump[word_idx+1];
20651                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
20652                                (UV)((dist ? this_trie + dist : next) - start));
20653                     if (dist) {
20654                         if (!nextbranch)
20655                             nextbranch= this_trie + trie->jump[0];
20656                         DUMPUNTIL(this_trie + dist, nextbranch);
20657                     }
20658                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
20659                         nextbranch= regnext((regnode *)nextbranch);
20660                 } else {
20661                     Perl_re_printf( aTHX_  "\n");
20662                 }
20663             }
20664             if (last && next > last)
20665                 node= last;
20666             else
20667                 node= next;
20668         }
20669         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
20670             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
20671                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
20672         }
20673         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
20674             assert(next);
20675             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
20676         }
20677         else if ( op == PLUS || op == STAR) {
20678             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
20679         }
20680         else if (PL_regkind[(U8)op] == ANYOF) {
20681             /* arglen 1 + class block */
20682             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
20683                           ? ANYOF_POSIXL_SKIP
20684                           : ANYOF_SKIP);
20685             node = NEXTOPER(node);
20686         }
20687         else if (PL_regkind[(U8)op] == EXACT) {
20688             /* Literal string, where present. */
20689             node += NODE_SZ_STR(node) - 1;
20690             node = NEXTOPER(node);
20691         }
20692         else {
20693             node = NEXTOPER(node);
20694             node += regarglen[(U8)op];
20695         }
20696         if (op == CURLYX || op == OPEN)
20697             indent++;
20698     }
20699     CLEAR_OPTSTART;
20700 #ifdef DEBUG_DUMPUNTIL
20701     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
20702 #endif
20703     return node;
20704 }
20705
20706 #endif  /* DEBUGGING */
20707
20708 /*
20709  * ex: set ts=8 sts=4 sw=4 et:
20710  */