This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
18e87e156c02da08a26b47dffc9391276cf90f21
[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)  strchr("-[]\\^", c)
123
124
125 struct RExC_state_t {
126     U32         flags;                  /* RXf_* are we folding, multilining? */
127     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
128     char        *precomp;               /* uncompiled string. */
129     char        *precomp_end;           /* pointer to end of uncompiled string. */
130     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
131     regexp      *rx;                    /* perl core regexp structure */
132     regexp_internal     *rxi;           /* internal data for regexp object
133                                            pprivate field */
134     char        *start;                 /* Start of input for compile */
135     char        *end;                   /* End of input for compile */
136     char        *parse;                 /* Input-scan pointer. */
137     char        *adjusted_start;        /* 'start', adjusted.  See code use */
138     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
139     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
140     regnode     *emit_start;            /* Start of emitted-code area */
141     regnode     *emit_bound;            /* First regnode outside of the
142                                            allocated space */
143     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
144                                            implies compiling, so don't emit */
145     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
146                                            large enough for the largest
147                                            non-EXACTish node, so can use it as
148                                            scratch in pass1 */
149     I32         naughty;                /* How bad is this pattern? */
150     I32         sawback;                /* Did we see \1, ...? */
151     U32         seen;
152     SSize_t     size;                   /* Code size. */
153     I32                npar;            /* Capture buffer count, (OPEN) plus
154                                            one. ("par" 0 is the whole
155                                            pattern)*/
156     I32         nestroot;               /* root parens we are in - used by
157                                            accept */
158     I32         extralen;
159     I32         seen_zerolen;
160     regnode     **open_parens;          /* pointers to open parens */
161     regnode     **close_parens;         /* pointers to close parens */
162     regnode     *end_op;                /* END node in program */
163     I32         utf8;           /* whether the pattern is utf8 or not */
164     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
165                                 /* XXX use this for future optimisation of case
166                                  * where pattern must be upgraded to utf8. */
167     I32         uni_semantics;  /* If a d charset modifier should use unicode
168                                    rules, even if the pattern is not in
169                                    utf8 */
170     HV          *paren_names;           /* Paren names */
171
172     regnode     **recurse;              /* Recurse regops */
173     I32                recurse_count;                /* Number of recurse regops we have generated */
174     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
175                                            through */
176     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
177     I32         in_lookbehind;
178     I32         contains_locale;
179     I32         override_recoding;
180 #ifdef EBCDIC
181     I32         recode_x_to_native;
182 #endif
183     I32         in_multi_char_class;
184     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
185                                             within pattern */
186     int         code_index;             /* next code_blocks[] slot */
187     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
188     scan_frame *frame_head;
189     scan_frame *frame_last;
190     U32         frame_count;
191     AV         *warn_text;
192 #ifdef ADD_TO_REGEXEC
193     char        *starttry;              /* -Dr: where regtry was called. */
194 #define RExC_starttry   (pRExC_state->starttry)
195 #endif
196     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
197 #ifdef DEBUGGING
198     const char  *lastparse;
199     I32         lastnum;
200     AV          *paren_name_list;       /* idx -> name */
201     U32         study_chunk_recursed_count;
202     SV          *mysv1;
203     SV          *mysv2;
204 #define RExC_lastparse  (pRExC_state->lastparse)
205 #define RExC_lastnum    (pRExC_state->lastnum)
206 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
207 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
208 #define RExC_mysv       (pRExC_state->mysv1)
209 #define RExC_mysv1      (pRExC_state->mysv1)
210 #define RExC_mysv2      (pRExC_state->mysv2)
211
212 #endif
213     bool        seen_unfolded_sharp_s;
214     bool        strict;
215     bool        study_started;
216 };
217
218 #define RExC_flags      (pRExC_state->flags)
219 #define RExC_pm_flags   (pRExC_state->pm_flags)
220 #define RExC_precomp    (pRExC_state->precomp)
221 #define RExC_precomp_adj (pRExC_state->precomp_adj)
222 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
223 #define RExC_precomp_end (pRExC_state->precomp_end)
224 #define RExC_rx_sv      (pRExC_state->rx_sv)
225 #define RExC_rx         (pRExC_state->rx)
226 #define RExC_rxi        (pRExC_state->rxi)
227 #define RExC_start      (pRExC_state->start)
228 #define RExC_end        (pRExC_state->end)
229 #define RExC_parse      (pRExC_state->parse)
230 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
231
232 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
233  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
234  * something forces the pattern into using /ui rules, the sharp s should be
235  * folded into the sequence 'ss', which takes up more space than previously
236  * calculated.  This means that the sizing pass needs to be restarted.  (The
237  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
238  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
239  * so there is no need to resize [perl #125990]. */
240 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
241
242 #ifdef RE_TRACK_PATTERN_OFFSETS
243 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
244                                                          others */
245 #endif
246 #define RExC_emit       (pRExC_state->emit)
247 #define RExC_emit_dummy (pRExC_state->emit_dummy)
248 #define RExC_emit_start (pRExC_state->emit_start)
249 #define RExC_emit_bound (pRExC_state->emit_bound)
250 #define RExC_sawback    (pRExC_state->sawback)
251 #define RExC_seen       (pRExC_state->seen)
252 #define RExC_size       (pRExC_state->size)
253 #define RExC_maxlen        (pRExC_state->maxlen)
254 #define RExC_npar       (pRExC_state->npar)
255 #define RExC_nestroot   (pRExC_state->nestroot)
256 #define RExC_extralen   (pRExC_state->extralen)
257 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
258 #define RExC_utf8       (pRExC_state->utf8)
259 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
260 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
261 #define RExC_open_parens        (pRExC_state->open_parens)
262 #define RExC_close_parens       (pRExC_state->close_parens)
263 #define RExC_end_op     (pRExC_state->end_op)
264 #define RExC_paren_names        (pRExC_state->paren_names)
265 #define RExC_recurse    (pRExC_state->recurse)
266 #define RExC_recurse_count      (pRExC_state->recurse_count)
267 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
268 #define RExC_study_chunk_recursed_bytes  \
269                                    (pRExC_state->study_chunk_recursed_bytes)
270 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
271 #define RExC_contains_locale    (pRExC_state->contains_locale)
272 #ifdef EBCDIC
273 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
274 #endif
275 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
276 #define RExC_frame_head (pRExC_state->frame_head)
277 #define RExC_frame_last (pRExC_state->frame_last)
278 #define RExC_frame_count (pRExC_state->frame_count)
279 #define RExC_strict (pRExC_state->strict)
280 #define RExC_study_started      (pRExC_state->study_started)
281 #define RExC_warn_text (pRExC_state->warn_text)
282
283 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
284  * a flag to disable back-off on the fixed/floating substrings - if it's
285  * a high complexity pattern we assume the benefit of avoiding a full match
286  * is worth the cost of checking for the substrings even if they rarely help.
287  */
288 #define RExC_naughty    (pRExC_state->naughty)
289 #define TOO_NAUGHTY (10)
290 #define MARK_NAUGHTY(add) \
291     if (RExC_naughty < TOO_NAUGHTY) \
292         RExC_naughty += (add)
293 #define MARK_NAUGHTY_EXP(exp, add) \
294     if (RExC_naughty < TOO_NAUGHTY) \
295         RExC_naughty += RExC_naughty / (exp) + (add)
296
297 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
298 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
299         ((*s) == '{' && regcurly(s)))
300
301 /*
302  * Flags to be passed up and down.
303  */
304 #define WORST           0       /* Worst case. */
305 #define HASWIDTH        0x01    /* Known to match non-null strings. */
306
307 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
308  * character.  (There needs to be a case: in the switch statement in regexec.c
309  * for any node marked SIMPLE.)  Note that this is not the same thing as
310  * REGNODE_SIMPLE */
311 #define SIMPLE          0x02
312 #define SPSTART         0x04    /* Starts with * or + */
313 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
314 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
315 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
316 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
317                                    calcuate sizes as UTF-8 */
318
319 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
320
321 /* whether trie related optimizations are enabled */
322 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
323 #define TRIE_STUDY_OPT
324 #define FULL_TRIE_STUDY
325 #define TRIE_STCLASS
326 #endif
327
328
329
330 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
331 #define PBITVAL(paren) (1 << ((paren) & 7))
332 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
333 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
334 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
335
336 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
337                                      if (!UTF) {                           \
338                                          assert(PASS1);                    \
339                                          *flagp = RESTART_PASS1|NEED_UTF8; \
340                                          return NULL;                      \
341                                      }                                     \
342                              } STMT_END
343
344 /* Change from /d into /u rules, and restart the parse if we've already seen
345  * something whose size would increase as a result, by setting *flagp and
346  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
347  * we've change to /u during the parse.  */
348 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
349     STMT_START {                                                            \
350             if (DEPENDS_SEMANTICS) {                                        \
351                 assert(PASS1);                                              \
352                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
353                 RExC_uni_semantics = 1;                                     \
354                 if (RExC_seen_unfolded_sharp_s) {                           \
355                     *flagp |= RESTART_PASS1;                                \
356                     return restart_retval;                                  \
357                 }                                                           \
358             }                                                               \
359     } STMT_END
360
361 /* This converts the named class defined in regcomp.h to its equivalent class
362  * number defined in handy.h. */
363 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
364 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
365
366 #define _invlist_union_complement_2nd(a, b, output) \
367                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
368 #define _invlist_intersection_complement_2nd(a, b, output) \
369                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
370
371 /* About scan_data_t.
372
373   During optimisation we recurse through the regexp program performing
374   various inplace (keyhole style) optimisations. In addition study_chunk
375   and scan_commit populate this data structure with information about
376   what strings MUST appear in the pattern. We look for the longest
377   string that must appear at a fixed location, and we look for the
378   longest string that may appear at a floating location. So for instance
379   in the pattern:
380
381     /FOO[xX]A.*B[xX]BAR/
382
383   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
384   strings (because they follow a .* construct). study_chunk will identify
385   both FOO and BAR as being the longest fixed and floating strings respectively.
386
387   The strings can be composites, for instance
388
389      /(f)(o)(o)/
390
391   will result in a composite fixed substring 'foo'.
392
393   For each string some basic information is maintained:
394
395   - min_offset
396     This is the position the string must appear at, or not before.
397     It also implicitly (when combined with minlenp) tells us how many
398     characters must match before the string we are searching for.
399     Likewise when combined with minlenp and the length of the string it
400     tells us how many characters must appear after the string we have
401     found.
402
403   - max_offset
404     Only used for floating strings. This is the rightmost point that
405     the string can appear at. If set to SSize_t_MAX it indicates that the
406     string can occur infinitely far to the right.
407     For fixed strings, it is equal to min_offset.
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 struct scan_data_substrs {
448     SV      *str;       /* longest substring found in pattern */
449     SSize_t min_offset; /* earliest point in string it can appear */
450     SSize_t max_offset; /* latest point in string it can appear */
451     SSize_t *minlenp;   /* pointer to the minlen relevant to the string */
452     SSize_t lookbehind; /* is the pos of the string modified by LB */
453     I32 flags;          /* per substring SF_* and SCF_* flags */
454 };
455
456 typedef struct scan_data_t {
457     /*I32 len_min;      unused */
458     /*I32 len_delta;    unused */
459     SSize_t pos_min;
460     SSize_t pos_delta;
461     SV *last_found;
462     SSize_t last_end;       /* min value, <0 unless valid. */
463     SSize_t last_start_min;
464     SSize_t last_start_max;
465     U8      cur_is_floating; /* whether the last_* values should be set as
466                               * the next fixed (0) or floating (1)
467                               * substring */
468
469     /* [0] is longest fixed substring so far, [1] is longest float so far */
470     struct scan_data_substrs  substrs[2];
471
472     I32 flags;             /* common SF_* and SCF_* flags */
473     I32 whilem_c;
474     SSize_t *last_closep;
475     regnode_ssc *start_class;
476 } scan_data_t;
477
478 /*
479  * Forward declarations for pregcomp()'s friends.
480  */
481
482 static const scan_data_t zero_scan_data = {
483     0, 0, NULL, 0, 0, 0, 0,
484     {
485         { NULL, 0, 0, 0, 0, 0 },
486         { NULL, 0, 0, 0, 0, 0 },
487     },
488     0, 0, NULL, NULL
489 };
490
491 /* study flags */
492
493 #define SF_BEFORE_SEOL          0x0001
494 #define SF_BEFORE_MEOL          0x0002
495 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
496
497 #define SF_IS_INF               0x0040
498 #define SF_HAS_PAR              0x0080
499 #define SF_IN_PAR               0x0100
500 #define SF_HAS_EVAL             0x0200
501
502
503 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
504  * longest substring in the pattern. When it is not set the optimiser keeps
505  * track of position, but does not keep track of the actual strings seen,
506  *
507  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
508  * /foo/i will not.
509  *
510  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
511  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
512  * turned off because of the alternation (BRANCH). */
513 #define SCF_DO_SUBSTR           0x0400
514
515 #define SCF_DO_STCLASS_AND      0x0800
516 #define SCF_DO_STCLASS_OR       0x1000
517 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
518 #define SCF_WHILEM_VISITED_POS  0x2000
519
520 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
521 #define SCF_SEEN_ACCEPT         0x8000
522 #define SCF_TRIE_DOING_RESTUDY 0x10000
523 #define SCF_IN_DEFINE          0x20000
524
525
526
527
528 #define UTF cBOOL(RExC_utf8)
529
530 /* The enums for all these are ordered so things work out correctly */
531 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
532 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
533                                                      == REGEX_DEPENDS_CHARSET)
534 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
535 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
536                                                      >= REGEX_UNICODE_CHARSET)
537 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
538                                             == REGEX_ASCII_RESTRICTED_CHARSET)
539 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
540                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
541 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
542                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
543
544 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
545
546 /* For programs that want to be strictly Unicode compatible by dying if any
547  * attempt is made to match a non-Unicode code point against a Unicode
548  * property.  */
549 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
550
551 #define OOB_NAMEDCLASS          -1
552
553 /* There is no code point that is out-of-bounds, so this is problematic.  But
554  * its only current use is to initialize a variable that is always set before
555  * looked at. */
556 #define OOB_UNICODE             0xDEADBEEF
557
558 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
559
560
561 /* length of regex to show in messages that don't mark a position within */
562 #define RegexLengthToShowInErrorMessages 127
563
564 /*
565  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
566  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
567  * op/pragma/warn/regcomp.
568  */
569 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
570 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
571
572 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
573                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
574
575 /* The code in this file in places uses one level of recursion with parsing
576  * rebased to an alternate string constructed by us in memory.  This can take
577  * the form of something that is completely different from the input, or
578  * something that uses the input as part of the alternate.  In the first case,
579  * there should be no possibility of an error, as we are in complete control of
580  * the alternate string.  But in the second case we don't control the input
581  * portion, so there may be errors in that.  Here's an example:
582  *      /[abc\x{DF}def]/ui
583  * is handled specially because \x{df} folds to a sequence of more than one
584  * character, 'ss'.  What is done is to create and parse an alternate string,
585  * which looks like this:
586  *      /(?:\x{DF}|[abc\x{DF}def])/ui
587  * where it uses the input unchanged in the middle of something it constructs,
588  * which is a branch for the DF outside the character class, and clustering
589  * parens around the whole thing. (It knows enough to skip the DF inside the
590  * class while in this substitute parse.) 'abc' and 'def' may have errors that
591  * need to be reported.  The general situation looks like this:
592  *
593  *              sI                       tI               xI       eI
594  * Input:       ----------------------------------------------------
595  * Constructed:         ---------------------------------------------------
596  *                      sC               tC               xC       eC     EC
597  *
598  * The input string sI..eI is the input pattern.  The string sC..EC is the
599  * constructed substitute parse string.  The portions sC..tC and eC..EC are
600  * constructed by us.  The portion tC..eC is an exact duplicate of the input
601  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
602  * while parsing, we find an error at xC.  We want to display a message showing
603  * the real input string.  Thus we need to find the point xI in it which
604  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
605  * been constructed by us, and so shouldn't have errors.  We get:
606  *
607  *      xI = sI + (tI - sI) + (xC - tC)
608  *
609  * and, the offset into sI is:
610  *
611  *      (xI - sI) = (tI - sI) + (xC - tC)
612  *
613  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
614  * and we save tC as RExC_adjusted_start.
615  *
616  * During normal processing of the input pattern, everything points to that,
617  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
618  */
619
620 #define tI_sI           RExC_precomp_adj
621 #define tC              RExC_adjusted_start
622 #define sC              RExC_precomp
623 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
624 #define xI(xC)          (sC + xI_offset(xC))
625 #define eC              RExC_precomp_end
626
627 #define REPORT_LOCATION_ARGS(xC)                                            \
628     UTF8fARG(UTF,                                                           \
629              (xI(xC) > eC) /* Don't run off end */                          \
630               ? eC - sC   /* Length before the <--HERE */                   \
631               : xI_offset(xC),                                              \
632              sC),         /* The input pattern printed up to the <--HERE */ \
633     UTF8fARG(UTF,                                                           \
634              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
635              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
636
637 /* Used to point after bad bytes for an error message, but avoid skipping
638  * past a nul byte. */
639 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
640
641 /*
642  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
643  * arg. Show regex, up to a maximum length. If it's too long, chop and add
644  * "...".
645  */
646 #define _FAIL(code) STMT_START {                                        \
647     const char *ellipses = "";                                          \
648     IV len = RExC_precomp_end - RExC_precomp;                                   \
649                                                                         \
650     if (!SIZE_ONLY)                                                     \
651         SAVEFREESV(RExC_rx_sv);                                         \
652     if (len > RegexLengthToShowInErrorMessages) {                       \
653         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
654         len = RegexLengthToShowInErrorMessages - 10;                    \
655         ellipses = "...";                                               \
656     }                                                                   \
657     code;                                                               \
658 } STMT_END
659
660 #define FAIL(msg) _FAIL(                            \
661     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
662             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
663
664 #define FAIL2(msg,arg) _FAIL(                       \
665     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
666             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
667
668 /*
669  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
670  */
671 #define Simple_vFAIL(m) STMT_START {                                    \
672     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
673             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
674 } STMT_END
675
676 /*
677  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
678  */
679 #define vFAIL(m) STMT_START {                           \
680     if (!SIZE_ONLY)                                     \
681         SAVEFREESV(RExC_rx_sv);                         \
682     Simple_vFAIL(m);                                    \
683 } STMT_END
684
685 /*
686  * Like Simple_vFAIL(), but accepts two arguments.
687  */
688 #define Simple_vFAIL2(m,a1) STMT_START {                        \
689     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
690                       REPORT_LOCATION_ARGS(RExC_parse));        \
691 } STMT_END
692
693 /*
694  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
695  */
696 #define vFAIL2(m,a1) STMT_START {                       \
697     if (!SIZE_ONLY)                                     \
698         SAVEFREESV(RExC_rx_sv);                         \
699     Simple_vFAIL2(m, a1);                               \
700 } STMT_END
701
702
703 /*
704  * Like Simple_vFAIL(), but accepts three arguments.
705  */
706 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
707     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
708             REPORT_LOCATION_ARGS(RExC_parse));                  \
709 } STMT_END
710
711 /*
712  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
713  */
714 #define vFAIL3(m,a1,a2) STMT_START {                    \
715     if (!SIZE_ONLY)                                     \
716         SAVEFREESV(RExC_rx_sv);                         \
717     Simple_vFAIL3(m, a1, a2);                           \
718 } STMT_END
719
720 /*
721  * Like Simple_vFAIL(), but accepts four arguments.
722  */
723 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
724     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
725             REPORT_LOCATION_ARGS(RExC_parse));                  \
726 } STMT_END
727
728 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
729     if (!SIZE_ONLY)                                     \
730         SAVEFREESV(RExC_rx_sv);                         \
731     Simple_vFAIL4(m, a1, a2, a3);                       \
732 } STMT_END
733
734 /* A specialized version of vFAIL2 that works with UTF8f */
735 #define vFAIL2utf8f(m, a1) STMT_START {             \
736     if (!SIZE_ONLY)                                 \
737         SAVEFREESV(RExC_rx_sv);                     \
738     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
739             REPORT_LOCATION_ARGS(RExC_parse));      \
740 } STMT_END
741
742 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
743     if (!SIZE_ONLY)                                     \
744         SAVEFREESV(RExC_rx_sv);                         \
745     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
746             REPORT_LOCATION_ARGS(RExC_parse));          \
747 } STMT_END
748
749 /* These have asserts in them because of [perl #122671] Many warnings in
750  * regcomp.c can occur twice.  If they get output in pass1 and later in that
751  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
752  * would get output again.  So they should be output in pass2, and these
753  * asserts make sure new warnings follow that paradigm. */
754
755 /* m is not necessarily a "literal string", in this macro */
756 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
757     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
758                                        "%s" REPORT_LOCATION,            \
759                                   m, REPORT_LOCATION_ARGS(loc));        \
760 } STMT_END
761
762 #define ckWARNreg(loc,m) STMT_START {                                   \
763     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
764                                           m REPORT_LOCATION,            \
765                                           REPORT_LOCATION_ARGS(loc));   \
766 } STMT_END
767
768 #define vWARN(loc, m) STMT_START {                                      \
769     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
770                                        m REPORT_LOCATION,               \
771                                        REPORT_LOCATION_ARGS(loc));      \
772 } STMT_END
773
774 #define vWARN_dep(loc, m) STMT_START {                                  \
775     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
776                                        m REPORT_LOCATION,               \
777                                        REPORT_LOCATION_ARGS(loc));      \
778 } STMT_END
779
780 #define ckWARNdep(loc,m) STMT_START {                                   \
781     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
782                                             m REPORT_LOCATION,          \
783                                             REPORT_LOCATION_ARGS(loc)); \
784 } STMT_END
785
786 #define ckWARNregdep(loc,m) STMT_START {                                    \
787     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
788                                                       WARN_REGEXP),         \
789                                              m REPORT_LOCATION,             \
790                                              REPORT_LOCATION_ARGS(loc));    \
791 } STMT_END
792
793 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
794     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
795                                             m REPORT_LOCATION,              \
796                                             a1, REPORT_LOCATION_ARGS(loc)); \
797 } STMT_END
798
799 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
800     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
801                                           m REPORT_LOCATION,                \
802                                           a1, REPORT_LOCATION_ARGS(loc));   \
803 } STMT_END
804
805 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
806     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
807                                        m REPORT_LOCATION,                   \
808                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
809 } STMT_END
810
811 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
812     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
813                                           m REPORT_LOCATION,                \
814                                           a1, a2,                           \
815                                           REPORT_LOCATION_ARGS(loc));       \
816 } STMT_END
817
818 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
819     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
820                                        m REPORT_LOCATION,               \
821                                        a1, a2, a3,                      \
822                                        REPORT_LOCATION_ARGS(loc));      \
823 } STMT_END
824
825 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
826     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
827                                           m REPORT_LOCATION,            \
828                                           a1, a2, a3,                   \
829                                           REPORT_LOCATION_ARGS(loc));   \
830 } STMT_END
831
832 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
833     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
834                                        m REPORT_LOCATION,               \
835                                        a1, a2, a3, a4,                  \
836                                        REPORT_LOCATION_ARGS(loc));      \
837 } STMT_END
838
839 /* Macros for recording node offsets.   20001227 mjd@plover.com
840  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
841  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
842  * Element 0 holds the number n.
843  * Position is 1 indexed.
844  */
845 #ifndef RE_TRACK_PATTERN_OFFSETS
846 #define Set_Node_Offset_To_R(node,byte)
847 #define Set_Node_Offset(node,byte)
848 #define Set_Cur_Node_Offset
849 #define Set_Node_Length_To_R(node,len)
850 #define Set_Node_Length(node,len)
851 #define Set_Node_Cur_Length(node,start)
852 #define Node_Offset(n)
853 #define Node_Length(n)
854 #define Set_Node_Offset_Length(node,offset,len)
855 #define ProgLen(ri) ri->u.proglen
856 #define SetProgLen(ri,x) ri->u.proglen = x
857 #else
858 #define ProgLen(ri) ri->u.offsets[0]
859 #define SetProgLen(ri,x) ri->u.offsets[0] = x
860 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
861     if (! SIZE_ONLY) {                                                  \
862         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
863                     __LINE__, (int)(node), (int)(byte)));               \
864         if((node) < 0) {                                                \
865             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
866                                          (int)(node));                  \
867         } else {                                                        \
868             RExC_offsets[2*(node)-1] = (byte);                          \
869         }                                                               \
870     }                                                                   \
871 } STMT_END
872
873 #define Set_Node_Offset(node,byte) \
874     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
875 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
876
877 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
878     if (! SIZE_ONLY) {                                                  \
879         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
880                 __LINE__, (int)(node), (int)(len)));                    \
881         if((node) < 0) {                                                \
882             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
883                                          (int)(node));                  \
884         } else {                                                        \
885             RExC_offsets[2*(node)] = (len);                             \
886         }                                                               \
887     }                                                                   \
888 } STMT_END
889
890 #define Set_Node_Length(node,len) \
891     Set_Node_Length_To_R((node)-RExC_emit_start, len)
892 #define Set_Node_Cur_Length(node, start)                \
893     Set_Node_Length(node, RExC_parse - start)
894
895 /* Get offsets and lengths */
896 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
897 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
898
899 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
900     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
901     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
902 } STMT_END
903 #endif
904
905 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
906 #define EXPERIMENTAL_INPLACESCAN
907 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
908
909 #ifdef DEBUGGING
910 int
911 Perl_re_printf(pTHX_ const char *fmt, ...)
912 {
913     va_list ap;
914     int result;
915     PerlIO *f= Perl_debug_log;
916     PERL_ARGS_ASSERT_RE_PRINTF;
917     va_start(ap, fmt);
918     result = PerlIO_vprintf(f, fmt, ap);
919     va_end(ap);
920     return result;
921 }
922
923 int
924 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
925 {
926     va_list ap;
927     int result;
928     PerlIO *f= Perl_debug_log;
929     PERL_ARGS_ASSERT_RE_INDENTF;
930     va_start(ap, depth);
931     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
932     result = PerlIO_vprintf(f, fmt, ap);
933     va_end(ap);
934     return result;
935 }
936 #endif /* DEBUGGING */
937
938 #define DEBUG_RExC_seen()                                                   \
939         DEBUG_OPTIMISE_MORE_r({                                             \
940             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
941                                                                             \
942             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
943                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
944                                                                             \
945             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
946                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
947                                                                             \
948             if (RExC_seen & REG_GPOS_SEEN)                                  \
949                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
950                                                                             \
951             if (RExC_seen & REG_RECURSE_SEEN)                               \
952                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
953                                                                             \
954             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
955                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
956                                                                             \
957             if (RExC_seen & REG_VERBARG_SEEN)                               \
958                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
959                                                                             \
960             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
961                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
962                                                                             \
963             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
964                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
965                                                                             \
966             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
967                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
968                                                                             \
969             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
970                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
971                                                                             \
972             Perl_re_printf( aTHX_ "\n");                                                \
973         });
974
975 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
976   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
977
978
979 #ifdef DEBUGGING
980 static void
981 S_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
982                                     const char *close_str)
983 {
984     if (!flags)
985         return;
986
987     Perl_re_printf( aTHX_  "%s", open_str);
988     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
989     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
990     DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
991     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
992     DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
993     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
994     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
995     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
996     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
997     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
998     DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
999     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
1000     DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
1001     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
1002     DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
1003     Perl_re_printf( aTHX_  "%s", close_str);
1004 }
1005
1006
1007 static void
1008 S_debug_studydata(pTHX_ const char *where, scan_data_t *data,
1009                     U32 depth, int is_inf)
1010 {
1011     GET_RE_DEBUG_FLAGS_DECL;
1012
1013     DEBUG_OPTIMISE_MORE_r({
1014         if (!data)
1015             return;
1016         Perl_re_indentf(aTHX_  "%s: Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
1017             depth,
1018             where,
1019             (IV)data->pos_min,
1020             (IV)data->pos_delta,
1021             (UV)data->flags
1022         );
1023
1024         S_debug_show_study_flags(aTHX_ data->flags," [","]");
1025
1026         Perl_re_printf( aTHX_
1027             " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
1028             (IV)data->whilem_c,
1029             (IV)(data->last_closep ? *((data)->last_closep) : -1),
1030             is_inf ? "INF " : ""
1031         );
1032
1033         if (data->last_found) {
1034             int i;
1035             Perl_re_printf(aTHX_
1036                 "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
1037                     SvPVX_const(data->last_found),
1038                     (IV)data->last_end,
1039                     (IV)data->last_start_min,
1040                     (IV)data->last_start_max
1041             );
1042
1043             for (i = 0; i < 2; i++) {
1044                 Perl_re_printf(aTHX_
1045                     " %s%s: '%s' @ %" IVdf "/%" IVdf,
1046                     data->cur_is_floating == i ? "*" : "",
1047                     i ? "Float" : "Fixed",
1048                     SvPVX_const(data->substrs[i].str),
1049                     (IV)data->substrs[i].min_offset,
1050                     (IV)data->substrs[i].max_offset
1051                 );
1052                 S_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
1053             }
1054         }
1055
1056         Perl_re_printf( aTHX_ "\n");
1057     });
1058 }
1059
1060
1061 static void
1062 S_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
1063                 regnode *scan, U32 depth, U32 flags)
1064 {
1065     GET_RE_DEBUG_FLAGS_DECL;
1066
1067     DEBUG_OPTIMISE_r({
1068         regnode *Next;
1069
1070         if (!scan)
1071             return;
1072         Next = regnext(scan);
1073         regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
1074         Perl_re_indentf( aTHX_   "%s>%3d: %s (%d)",
1075             depth,
1076             str,
1077             REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
1078             Next ? (REG_NODE_NUM(Next)) : 0 );
1079         S_debug_show_study_flags(aTHX_ flags," [ ","]");
1080         Perl_re_printf( aTHX_  "\n");
1081    });
1082 }
1083
1084
1085 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) \
1086                     S_debug_studydata(aTHX_ where, data, depth, is_inf)
1087
1088 #  define DEBUG_PEEP(str, scan, depth, flags)   \
1089                     S_debug_peep(aTHX_ str, pRExC_state, scan, depth, flags)
1090
1091 #else
1092 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) NOOP
1093 #  define DEBUG_PEEP(str, scan, depth, flags)         NOOP
1094 #endif
1095
1096
1097 /* =========================================================
1098  * BEGIN edit_distance stuff.
1099  *
1100  * This calculates how many single character changes of any type are needed to
1101  * transform a string into another one.  It is taken from version 3.1 of
1102  *
1103  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1104  */
1105
1106 /* Our unsorted dictionary linked list.   */
1107 /* Note we use UVs, not chars. */
1108
1109 struct dictionary{
1110   UV key;
1111   UV value;
1112   struct dictionary* next;
1113 };
1114 typedef struct dictionary item;
1115
1116
1117 PERL_STATIC_INLINE item*
1118 push(UV key,item* curr)
1119 {
1120     item* head;
1121     Newxz(head, 1, item);
1122     head->key = key;
1123     head->value = 0;
1124     head->next = curr;
1125     return head;
1126 }
1127
1128
1129 PERL_STATIC_INLINE item*
1130 find(item* head, UV key)
1131 {
1132     item* iterator = head;
1133     while (iterator){
1134         if (iterator->key == key){
1135             return iterator;
1136         }
1137         iterator = iterator->next;
1138     }
1139
1140     return NULL;
1141 }
1142
1143 PERL_STATIC_INLINE item*
1144 uniquePush(item* head,UV key)
1145 {
1146     item* iterator = head;
1147
1148     while (iterator){
1149         if (iterator->key == key) {
1150             return head;
1151         }
1152         iterator = iterator->next;
1153     }
1154
1155     return push(key,head);
1156 }
1157
1158 PERL_STATIC_INLINE void
1159 dict_free(item* head)
1160 {
1161     item* iterator = head;
1162
1163     while (iterator) {
1164         item* temp = iterator;
1165         iterator = iterator->next;
1166         Safefree(temp);
1167     }
1168
1169     head = NULL;
1170 }
1171
1172 /* End of Dictionary Stuff */
1173
1174 /* All calculations/work are done here */
1175 STATIC int
1176 S_edit_distance(const UV* src,
1177                 const UV* tgt,
1178                 const STRLEN x,             /* length of src[] */
1179                 const STRLEN y,             /* length of tgt[] */
1180                 const SSize_t maxDistance
1181 )
1182 {
1183     item *head = NULL;
1184     UV swapCount,swapScore,targetCharCount,i,j;
1185     UV *scores;
1186     UV score_ceil = x + y;
1187
1188     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1189
1190     /* intialize matrix start values */
1191     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1192     scores[0] = score_ceil;
1193     scores[1 * (y + 2) + 0] = score_ceil;
1194     scores[0 * (y + 2) + 1] = score_ceil;
1195     scores[1 * (y + 2) + 1] = 0;
1196     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1197
1198     /* work loops    */
1199     /* i = src index */
1200     /* j = tgt index */
1201     for (i=1;i<=x;i++) {
1202         if (i < x)
1203             head = uniquePush(head,src[i]);
1204         scores[(i+1) * (y + 2) + 1] = i;
1205         scores[(i+1) * (y + 2) + 0] = score_ceil;
1206         swapCount = 0;
1207
1208         for (j=1;j<=y;j++) {
1209             if (i == 1) {
1210                 if(j < y)
1211                 head = uniquePush(head,tgt[j]);
1212                 scores[1 * (y + 2) + (j + 1)] = j;
1213                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1214             }
1215
1216             targetCharCount = find(head,tgt[j-1])->value;
1217             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1218
1219             if (src[i-1] != tgt[j-1]){
1220                 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));
1221             }
1222             else {
1223                 swapCount = j;
1224                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1225             }
1226         }
1227
1228         find(head,src[i-1])->value = i;
1229     }
1230
1231     {
1232         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1233         dict_free(head);
1234         Safefree(scores);
1235         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1236     }
1237 }
1238
1239 /* END of edit_distance() stuff
1240  * ========================================================= */
1241
1242 /* is c a control character for which we have a mnemonic? */
1243 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1244
1245 STATIC const char *
1246 S_cntrl_to_mnemonic(const U8 c)
1247 {
1248     /* Returns the mnemonic string that represents character 'c', if one
1249      * exists; NULL otherwise.  The only ones that exist for the purposes of
1250      * this routine are a few control characters */
1251
1252     switch (c) {
1253         case '\a':       return "\\a";
1254         case '\b':       return "\\b";
1255         case ESC_NATIVE: return "\\e";
1256         case '\f':       return "\\f";
1257         case '\n':       return "\\n";
1258         case '\r':       return "\\r";
1259         case '\t':       return "\\t";
1260     }
1261
1262     return NULL;
1263 }
1264
1265 /* Mark that we cannot extend a found fixed substring at this point.
1266    Update the longest found anchored substring or the longest found
1267    floating substrings if needed. */
1268
1269 STATIC void
1270 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1271                     SSize_t *minlenp, int is_inf)
1272 {
1273     const STRLEN l = CHR_SVLEN(data->last_found);
1274     SV * const longest_sv = data->substrs[data->cur_is_floating].str;
1275     const STRLEN old_l = CHR_SVLEN(longest_sv);
1276     GET_RE_DEBUG_FLAGS_DECL;
1277
1278     PERL_ARGS_ASSERT_SCAN_COMMIT;
1279
1280     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1281         const U8 i = data->cur_is_floating;
1282         SvSetMagicSV(longest_sv, data->last_found);
1283         data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min;
1284
1285         if (!i) /* fixed */
1286             data->substrs[0].max_offset = data->substrs[0].min_offset;
1287         else { /* float */
1288             data->substrs[1].max_offset = (l
1289                           ? data->last_start_max
1290                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1291                                          ? SSize_t_MAX
1292                                          : data->pos_min + data->pos_delta));
1293             if (is_inf
1294                  || (STRLEN)data->substrs[1].max_offset > (STRLEN)SSize_t_MAX)
1295                 data->substrs[1].max_offset = SSize_t_MAX;
1296         }
1297
1298         if (data->flags & SF_BEFORE_EOL)
1299             data->substrs[i].flags |= (data->flags & SF_BEFORE_EOL);
1300         else
1301             data->substrs[i].flags &= ~SF_BEFORE_EOL;
1302         data->substrs[i].minlenp = minlenp;
1303         data->substrs[i].lookbehind = 0;
1304     }
1305
1306     SvCUR_set(data->last_found, 0);
1307     {
1308         SV * const sv = data->last_found;
1309         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1310             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1311             if (mg)
1312                 mg->mg_len = 0;
1313         }
1314     }
1315     data->last_end = -1;
1316     data->flags &= ~SF_BEFORE_EOL;
1317     DEBUG_STUDYDATA("commit", data, 0, is_inf);
1318 }
1319
1320 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1321  * list that describes which code points it matches */
1322
1323 STATIC void
1324 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1325 {
1326     /* Set the SSC 'ssc' to match an empty string or any code point */
1327
1328     PERL_ARGS_ASSERT_SSC_ANYTHING;
1329
1330     assert(is_ANYOF_SYNTHETIC(ssc));
1331
1332     /* mortalize so won't leak */
1333     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1334     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1335 }
1336
1337 STATIC int
1338 S_ssc_is_anything(const regnode_ssc *ssc)
1339 {
1340     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1341      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1342      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1343      * in any way, so there's no point in using it */
1344
1345     UV start, end;
1346     bool ret;
1347
1348     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1349
1350     assert(is_ANYOF_SYNTHETIC(ssc));
1351
1352     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1353         return FALSE;
1354     }
1355
1356     /* See if the list consists solely of the range 0 - Infinity */
1357     invlist_iterinit(ssc->invlist);
1358     ret = invlist_iternext(ssc->invlist, &start, &end)
1359           && start == 0
1360           && end == UV_MAX;
1361
1362     invlist_iterfinish(ssc->invlist);
1363
1364     if (ret) {
1365         return TRUE;
1366     }
1367
1368     /* If e.g., both \w and \W are set, matches everything */
1369     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1370         int i;
1371         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1372             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1373                 return TRUE;
1374             }
1375         }
1376     }
1377
1378     return FALSE;
1379 }
1380
1381 STATIC void
1382 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1383 {
1384     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1385      * string, any code point, or any posix class under locale */
1386
1387     PERL_ARGS_ASSERT_SSC_INIT;
1388
1389     Zero(ssc, 1, regnode_ssc);
1390     set_ANYOF_SYNTHETIC(ssc);
1391     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1392     ssc_anything(ssc);
1393
1394     /* If any portion of the regex is to operate under locale rules that aren't
1395      * fully known at compile time, initialization includes it.  The reason
1396      * this isn't done for all regexes is that the optimizer was written under
1397      * the assumption that locale was all-or-nothing.  Given the complexity and
1398      * lack of documentation in the optimizer, and that there are inadequate
1399      * test cases for locale, many parts of it may not work properly, it is
1400      * safest to avoid locale unless necessary. */
1401     if (RExC_contains_locale) {
1402         ANYOF_POSIXL_SETALL(ssc);
1403     }
1404     else {
1405         ANYOF_POSIXL_ZERO(ssc);
1406     }
1407 }
1408
1409 STATIC int
1410 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1411                         const regnode_ssc *ssc)
1412 {
1413     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1414      * to the list of code points matched, and locale posix classes; hence does
1415      * not check its flags) */
1416
1417     UV start, end;
1418     bool ret;
1419
1420     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1421
1422     assert(is_ANYOF_SYNTHETIC(ssc));
1423
1424     invlist_iterinit(ssc->invlist);
1425     ret = invlist_iternext(ssc->invlist, &start, &end)
1426           && start == 0
1427           && end == UV_MAX;
1428
1429     invlist_iterfinish(ssc->invlist);
1430
1431     if (! ret) {
1432         return FALSE;
1433     }
1434
1435     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1436         return FALSE;
1437     }
1438
1439     return TRUE;
1440 }
1441
1442 STATIC SV*
1443 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1444                                const regnode_charclass* const node)
1445 {
1446     /* Returns a mortal inversion list defining which code points are matched
1447      * by 'node', which is of type ANYOF.  Handles complementing the result if
1448      * appropriate.  If some code points aren't knowable at this time, the
1449      * returned list must, and will, contain every code point that is a
1450      * possibility. */
1451
1452     SV* invlist = NULL;
1453     SV* only_utf8_locale_invlist = NULL;
1454     unsigned int i;
1455     const U32 n = ARG(node);
1456     bool new_node_has_latin1 = FALSE;
1457
1458     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1459
1460     /* Look at the data structure created by S_set_ANYOF_arg() */
1461     if (n != ANYOF_ONLY_HAS_BITMAP) {
1462         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1463         AV * const av = MUTABLE_AV(SvRV(rv));
1464         SV **const ary = AvARRAY(av);
1465         assert(RExC_rxi->data->what[n] == 's');
1466
1467         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1468             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1469         }
1470         else if (ary[0] && ary[0] != &PL_sv_undef) {
1471
1472             /* Here, no compile-time swash, and there are things that won't be
1473              * known until runtime -- we have to assume it could be anything */
1474             invlist = sv_2mortal(_new_invlist(1));
1475             return _add_range_to_invlist(invlist, 0, UV_MAX);
1476         }
1477         else if (ary[3] && ary[3] != &PL_sv_undef) {
1478
1479             /* Here no compile-time swash, and no run-time only data.  Use the
1480              * node's inversion list */
1481             invlist = sv_2mortal(invlist_clone(ary[3]));
1482         }
1483
1484         /* Get the code points valid only under UTF-8 locales */
1485         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1486             && ary[2] && ary[2] != &PL_sv_undef)
1487         {
1488             only_utf8_locale_invlist = ary[2];
1489         }
1490     }
1491
1492     if (! invlist) {
1493         invlist = sv_2mortal(_new_invlist(0));
1494     }
1495
1496     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1497      * code points, and an inversion list for the others, but if there are code
1498      * points that should match only conditionally on the target string being
1499      * UTF-8, those are placed in the inversion list, and not the bitmap.
1500      * Since there are circumstances under which they could match, they are
1501      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1502      * to exclude them here, so that when we invert below, the end result
1503      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1504      * have to do this here before we add the unconditionally matched code
1505      * points */
1506     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1507         _invlist_intersection_complement_2nd(invlist,
1508                                              PL_UpperLatin1,
1509                                              &invlist);
1510     }
1511
1512     /* Add in the points from the bit map */
1513     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1514         if (ANYOF_BITMAP_TEST(node, i)) {
1515             unsigned int start = i++;
1516
1517             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1518                 /* empty */
1519             }
1520             invlist = _add_range_to_invlist(invlist, start, i-1);
1521             new_node_has_latin1 = TRUE;
1522         }
1523     }
1524
1525     /* If this can match all upper Latin1 code points, have to add them
1526      * as well.  But don't add them if inverting, as when that gets done below,
1527      * it would exclude all these characters, including the ones it shouldn't
1528      * that were added just above */
1529     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1530         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1531     {
1532         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1533     }
1534
1535     /* Similarly for these */
1536     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1537         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1538     }
1539
1540     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1541         _invlist_invert(invlist);
1542     }
1543     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1544
1545         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1546          * locale.  We can skip this if there are no 0-255 at all. */
1547         _invlist_union(invlist, PL_Latin1, &invlist);
1548     }
1549
1550     /* Similarly add the UTF-8 locale possible matches.  These have to be
1551      * deferred until after the non-UTF-8 locale ones are taken care of just
1552      * above, or it leads to wrong results under ANYOF_INVERT */
1553     if (only_utf8_locale_invlist) {
1554         _invlist_union_maybe_complement_2nd(invlist,
1555                                             only_utf8_locale_invlist,
1556                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1557                                             &invlist);
1558     }
1559
1560     return invlist;
1561 }
1562
1563 /* These two functions currently do the exact same thing */
1564 #define ssc_init_zero           ssc_init
1565
1566 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1567 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1568
1569 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1570  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1571  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1572
1573 STATIC void
1574 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1575                 const regnode_charclass *and_with)
1576 {
1577     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1578      * another SSC or a regular ANYOF class.  Can create false positives. */
1579
1580     SV* anded_cp_list;
1581     U8  anded_flags;
1582
1583     PERL_ARGS_ASSERT_SSC_AND;
1584
1585     assert(is_ANYOF_SYNTHETIC(ssc));
1586
1587     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1588      * the code point inversion list and just the relevant flags */
1589     if (is_ANYOF_SYNTHETIC(and_with)) {
1590         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1591         anded_flags = ANYOF_FLAGS(and_with);
1592
1593         /* XXX This is a kludge around what appears to be deficiencies in the
1594          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1595          * there are paths through the optimizer where it doesn't get weeded
1596          * out when it should.  And if we don't make some extra provision for
1597          * it like the code just below, it doesn't get added when it should.
1598          * This solution is to add it only when AND'ing, which is here, and
1599          * only when what is being AND'ed is the pristine, original node
1600          * matching anything.  Thus it is like adding it to ssc_anything() but
1601          * only when the result is to be AND'ed.  Probably the same solution
1602          * could be adopted for the same problem we have with /l matching,
1603          * which is solved differently in S_ssc_init(), and that would lead to
1604          * fewer false positives than that solution has.  But if this solution
1605          * creates bugs, the consequences are only that a warning isn't raised
1606          * that should be; while the consequences for having /l bugs is
1607          * incorrect matches */
1608         if (ssc_is_anything((regnode_ssc *)and_with)) {
1609             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1610         }
1611     }
1612     else {
1613         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1614         if (OP(and_with) == ANYOFD) {
1615             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1616         }
1617         else {
1618             anded_flags = ANYOF_FLAGS(and_with)
1619             &( ANYOF_COMMON_FLAGS
1620               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1621               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1622             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1623                 anded_flags &=
1624                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1625             }
1626         }
1627     }
1628
1629     ANYOF_FLAGS(ssc) &= anded_flags;
1630
1631     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1632      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1633      * 'and_with' may be inverted.  When not inverted, we have the situation of
1634      * computing:
1635      *  (C1 | P1) & (C2 | P2)
1636      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1637      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1638      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1639      *                    <=  ((C1 & C2) | P1 | P2)
1640      * Alternatively, the last few steps could be:
1641      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1642      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1643      *                    <=  (C1 | C2 | (P1 & P2))
1644      * We favor the second approach if either P1 or P2 is non-empty.  This is
1645      * because these components are a barrier to doing optimizations, as what
1646      * they match cannot be known until the moment of matching as they are
1647      * dependent on the current locale, 'AND"ing them likely will reduce or
1648      * eliminate them.
1649      * But we can do better if we know that C1,P1 are in their initial state (a
1650      * frequent occurrence), each matching everything:
1651      *  (<everything>) & (C2 | P2) =  C2 | P2
1652      * Similarly, if C2,P2 are in their initial state (again a frequent
1653      * occurrence), the result is a no-op
1654      *  (C1 | P1) & (<everything>) =  C1 | P1
1655      *
1656      * Inverted, we have
1657      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1658      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1659      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1660      * */
1661
1662     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1663         && ! is_ANYOF_SYNTHETIC(and_with))
1664     {
1665         unsigned int i;
1666
1667         ssc_intersection(ssc,
1668                          anded_cp_list,
1669                          FALSE /* Has already been inverted */
1670                          );
1671
1672         /* If either P1 or P2 is empty, the intersection will be also; can skip
1673          * the loop */
1674         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1675             ANYOF_POSIXL_ZERO(ssc);
1676         }
1677         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1678
1679             /* Note that the Posix class component P from 'and_with' actually
1680              * looks like:
1681              *      P = Pa | Pb | ... | Pn
1682              * where each component is one posix class, such as in [\w\s].
1683              * Thus
1684              *      ~P = ~(Pa | Pb | ... | Pn)
1685              *         = ~Pa & ~Pb & ... & ~Pn
1686              *        <= ~Pa | ~Pb | ... | ~Pn
1687              * The last is something we can easily calculate, but unfortunately
1688              * is likely to have many false positives.  We could do better
1689              * in some (but certainly not all) instances if two classes in
1690              * P have known relationships.  For example
1691              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1692              * So
1693              *      :lower: & :print: = :lower:
1694              * And similarly for classes that must be disjoint.  For example,
1695              * since \s and \w can have no elements in common based on rules in
1696              * the POSIX standard,
1697              *      \w & ^\S = nothing
1698              * Unfortunately, some vendor locales do not meet the Posix
1699              * standard, in particular almost everything by Microsoft.
1700              * The loop below just changes e.g., \w into \W and vice versa */
1701
1702             regnode_charclass_posixl temp;
1703             int add = 1;    /* To calculate the index of the complement */
1704
1705             ANYOF_POSIXL_ZERO(&temp);
1706             for (i = 0; i < ANYOF_MAX; i++) {
1707                 assert(i % 2 != 0
1708                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1709                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1710
1711                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1712                     ANYOF_POSIXL_SET(&temp, i + add);
1713                 }
1714                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1715             }
1716             ANYOF_POSIXL_AND(&temp, ssc);
1717
1718         } /* else ssc already has no posixes */
1719     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1720          in its initial state */
1721     else if (! is_ANYOF_SYNTHETIC(and_with)
1722              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1723     {
1724         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1725          * copy it over 'ssc' */
1726         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1727             if (is_ANYOF_SYNTHETIC(and_with)) {
1728                 StructCopy(and_with, ssc, regnode_ssc);
1729             }
1730             else {
1731                 ssc->invlist = anded_cp_list;
1732                 ANYOF_POSIXL_ZERO(ssc);
1733                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1734                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1735                 }
1736             }
1737         }
1738         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1739                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1740         {
1741             /* One or the other of P1, P2 is non-empty. */
1742             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1743                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1744             }
1745             ssc_union(ssc, anded_cp_list, FALSE);
1746         }
1747         else { /* P1 = P2 = empty */
1748             ssc_intersection(ssc, anded_cp_list, FALSE);
1749         }
1750     }
1751 }
1752
1753 STATIC void
1754 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1755                const regnode_charclass *or_with)
1756 {
1757     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1758      * another SSC or a regular ANYOF class.  Can create false positives if
1759      * 'or_with' is to be inverted. */
1760
1761     SV* ored_cp_list;
1762     U8 ored_flags;
1763
1764     PERL_ARGS_ASSERT_SSC_OR;
1765
1766     assert(is_ANYOF_SYNTHETIC(ssc));
1767
1768     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1769      * the code point inversion list and just the relevant flags */
1770     if (is_ANYOF_SYNTHETIC(or_with)) {
1771         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1772         ored_flags = ANYOF_FLAGS(or_with);
1773     }
1774     else {
1775         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1776         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1777         if (OP(or_with) != ANYOFD) {
1778             ored_flags
1779             |= ANYOF_FLAGS(or_with)
1780              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1781                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1782             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1783                 ored_flags |=
1784                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1785             }
1786         }
1787     }
1788
1789     ANYOF_FLAGS(ssc) |= ored_flags;
1790
1791     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1792      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1793      * 'or_with' may be inverted.  When not inverted, we have the simple
1794      * situation of computing:
1795      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1796      * If P1|P2 yields a situation with both a class and its complement are
1797      * set, like having both \w and \W, this matches all code points, and we
1798      * can delete these from the P component of the ssc going forward.  XXX We
1799      * might be able to delete all the P components, but I (khw) am not certain
1800      * about this, and it is better to be safe.
1801      *
1802      * Inverted, we have
1803      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1804      *                         <=  (C1 | P1) | ~C2
1805      *                         <=  (C1 | ~C2) | P1
1806      * (which results in actually simpler code than the non-inverted case)
1807      * */
1808
1809     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1810         && ! is_ANYOF_SYNTHETIC(or_with))
1811     {
1812         /* We ignore P2, leaving P1 going forward */
1813     }   /* else  Not inverted */
1814     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1815         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1816         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1817             unsigned int i;
1818             for (i = 0; i < ANYOF_MAX; i += 2) {
1819                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1820                 {
1821                     ssc_match_all_cp(ssc);
1822                     ANYOF_POSIXL_CLEAR(ssc, i);
1823                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1824                 }
1825             }
1826         }
1827     }
1828
1829     ssc_union(ssc,
1830               ored_cp_list,
1831               FALSE /* Already has been inverted */
1832               );
1833 }
1834
1835 PERL_STATIC_INLINE void
1836 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1837 {
1838     PERL_ARGS_ASSERT_SSC_UNION;
1839
1840     assert(is_ANYOF_SYNTHETIC(ssc));
1841
1842     _invlist_union_maybe_complement_2nd(ssc->invlist,
1843                                         invlist,
1844                                         invert2nd,
1845                                         &ssc->invlist);
1846 }
1847
1848 PERL_STATIC_INLINE void
1849 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1850                          SV* const invlist,
1851                          const bool invert2nd)
1852 {
1853     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1854
1855     assert(is_ANYOF_SYNTHETIC(ssc));
1856
1857     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1858                                                invlist,
1859                                                invert2nd,
1860                                                &ssc->invlist);
1861 }
1862
1863 PERL_STATIC_INLINE void
1864 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1865 {
1866     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1867
1868     assert(is_ANYOF_SYNTHETIC(ssc));
1869
1870     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1871 }
1872
1873 PERL_STATIC_INLINE void
1874 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1875 {
1876     /* AND just the single code point 'cp' into the SSC 'ssc' */
1877
1878     SV* cp_list = _new_invlist(2);
1879
1880     PERL_ARGS_ASSERT_SSC_CP_AND;
1881
1882     assert(is_ANYOF_SYNTHETIC(ssc));
1883
1884     cp_list = add_cp_to_invlist(cp_list, cp);
1885     ssc_intersection(ssc, cp_list,
1886                      FALSE /* Not inverted */
1887                      );
1888     SvREFCNT_dec_NN(cp_list);
1889 }
1890
1891 PERL_STATIC_INLINE void
1892 S_ssc_clear_locale(regnode_ssc *ssc)
1893 {
1894     /* Set the SSC 'ssc' to not match any locale things */
1895     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1896
1897     assert(is_ANYOF_SYNTHETIC(ssc));
1898
1899     ANYOF_POSIXL_ZERO(ssc);
1900     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1901 }
1902
1903 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1904
1905 STATIC bool
1906 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1907 {
1908     /* The synthetic start class is used to hopefully quickly winnow down
1909      * places where a pattern could start a match in the target string.  If it
1910      * doesn't really narrow things down that much, there isn't much point to
1911      * having the overhead of using it.  This function uses some very crude
1912      * heuristics to decide if to use the ssc or not.
1913      *
1914      * It returns TRUE if 'ssc' rules out more than half what it considers to
1915      * be the "likely" possible matches, but of course it doesn't know what the
1916      * actual things being matched are going to be; these are only guesses
1917      *
1918      * For /l matches, it assumes that the only likely matches are going to be
1919      *      in the 0-255 range, uniformly distributed, so half of that is 127
1920      * For /a and /d matches, it assumes that the likely matches will be just
1921      *      the ASCII range, so half of that is 63
1922      * For /u and there isn't anything matching above the Latin1 range, it
1923      *      assumes that that is the only range likely to be matched, and uses
1924      *      half that as the cut-off: 127.  If anything matches above Latin1,
1925      *      it assumes that all of Unicode could match (uniformly), except for
1926      *      non-Unicode code points and things in the General Category "Other"
1927      *      (unassigned, private use, surrogates, controls and formats).  This
1928      *      is a much large number. */
1929
1930     U32 count = 0;      /* Running total of number of code points matched by
1931                            'ssc' */
1932     UV start, end;      /* Start and end points of current range in inversion
1933                            list */
1934     const U32 max_code_points = (LOC)
1935                                 ?  256
1936                                 : ((   ! UNI_SEMANTICS
1937                                      || invlist_highest(ssc->invlist) < 256)
1938                                   ? 128
1939                                   : NON_OTHER_COUNT);
1940     const U32 max_match = max_code_points / 2;
1941
1942     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1943
1944     invlist_iterinit(ssc->invlist);
1945     while (invlist_iternext(ssc->invlist, &start, &end)) {
1946         if (start >= max_code_points) {
1947             break;
1948         }
1949         end = MIN(end, max_code_points - 1);
1950         count += end - start + 1;
1951         if (count >= max_match) {
1952             invlist_iterfinish(ssc->invlist);
1953             return FALSE;
1954         }
1955     }
1956
1957     return TRUE;
1958 }
1959
1960
1961 STATIC void
1962 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1963 {
1964     /* The inversion list in the SSC is marked mortal; now we need a more
1965      * permanent copy, which is stored the same way that is done in a regular
1966      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1967      * map */
1968
1969     SV* invlist = invlist_clone(ssc->invlist);
1970
1971     PERL_ARGS_ASSERT_SSC_FINALIZE;
1972
1973     assert(is_ANYOF_SYNTHETIC(ssc));
1974
1975     /* The code in this file assumes that all but these flags aren't relevant
1976      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1977      * by the time we reach here */
1978     assert(! (ANYOF_FLAGS(ssc)
1979         & ~( ANYOF_COMMON_FLAGS
1980             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1981             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
1982
1983     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1984
1985     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1986                                 NULL, NULL, NULL, FALSE);
1987
1988     /* Make sure is clone-safe */
1989     ssc->invlist = NULL;
1990
1991     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1992         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1993     }
1994
1995     if (RExC_contains_locale) {
1996         OP(ssc) = ANYOFL;
1997     }
1998
1999     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
2000 }
2001
2002 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
2003 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
2004 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
2005 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
2006                                ? (TRIE_LIST_CUR( idx ) - 1)           \
2007                                : 0 )
2008
2009
2010 #ifdef DEBUGGING
2011 /*
2012    dump_trie(trie,widecharmap,revcharmap)
2013    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
2014    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
2015
2016    These routines dump out a trie in a somewhat readable format.
2017    The _interim_ variants are used for debugging the interim
2018    tables that are used to generate the final compressed
2019    representation which is what dump_trie expects.
2020
2021    Part of the reason for their existence is to provide a form
2022    of documentation as to how the different representations function.
2023
2024 */
2025
2026 /*
2027   Dumps the final compressed table form of the trie to Perl_debug_log.
2028   Used for debugging make_trie().
2029 */
2030
2031 STATIC void
2032 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
2033             AV *revcharmap, U32 depth)
2034 {
2035     U32 state;
2036     SV *sv=sv_newmortal();
2037     int colwidth= widecharmap ? 6 : 4;
2038     U16 word;
2039     GET_RE_DEBUG_FLAGS_DECL;
2040
2041     PERL_ARGS_ASSERT_DUMP_TRIE;
2042
2043     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
2044         depth+1, "Match","Base","Ofs" );
2045
2046     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
2047         SV ** const tmp = av_fetch( revcharmap, state, 0);
2048         if ( tmp ) {
2049             Perl_re_printf( aTHX_  "%*s",
2050                 colwidth,
2051                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2052                             PL_colors[0], PL_colors[1],
2053                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2054                             PERL_PV_ESCAPE_FIRSTCHAR
2055                 )
2056             );
2057         }
2058     }
2059     Perl_re_printf( aTHX_  "\n");
2060     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2061
2062     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2063         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2064     Perl_re_printf( aTHX_  "\n");
2065
2066     for( state = 1 ; state < trie->statecount ; state++ ) {
2067         const U32 base = trie->states[ state ].trans.base;
2068
2069         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2070
2071         if ( trie->states[ state ].wordnum ) {
2072             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2073         } else {
2074             Perl_re_printf( aTHX_  "%6s", "" );
2075         }
2076
2077         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2078
2079         if ( base ) {
2080             U32 ofs = 0;
2081
2082             while( ( base + ofs  < trie->uniquecharcount ) ||
2083                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2084                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2085                                                                     != state))
2086                     ofs++;
2087
2088             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2089
2090             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2091                 if ( ( base + ofs >= trie->uniquecharcount )
2092                         && ( base + ofs - trie->uniquecharcount
2093                                                         < trie->lasttrans )
2094                         && trie->trans[ base + ofs
2095                                     - trie->uniquecharcount ].check == state )
2096                 {
2097                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2098                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2099                    );
2100                 } else {
2101                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2102                 }
2103             }
2104
2105             Perl_re_printf( aTHX_  "]");
2106
2107         }
2108         Perl_re_printf( aTHX_  "\n" );
2109     }
2110     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2111                                 depth);
2112     for (word=1; word <= trie->wordcount; word++) {
2113         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2114             (int)word, (int)(trie->wordinfo[word].prev),
2115             (int)(trie->wordinfo[word].len));
2116     }
2117     Perl_re_printf( aTHX_  "\n" );
2118 }
2119 /*
2120   Dumps a fully constructed but uncompressed trie in list form.
2121   List tries normally only are used for construction when the number of
2122   possible chars (trie->uniquecharcount) is very high.
2123   Used for debugging make_trie().
2124 */
2125 STATIC void
2126 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2127                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2128                          U32 depth)
2129 {
2130     U32 state;
2131     SV *sv=sv_newmortal();
2132     int colwidth= widecharmap ? 6 : 4;
2133     GET_RE_DEBUG_FLAGS_DECL;
2134
2135     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2136
2137     /* print out the table precompression.  */
2138     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2139             depth+1 );
2140     Perl_re_indentf( aTHX_  "%s",
2141             depth+1, "------:-----+-----------------\n" );
2142
2143     for( state=1 ; state < next_alloc ; state ++ ) {
2144         U16 charid;
2145
2146         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2147             depth+1, (UV)state  );
2148         if ( ! trie->states[ state ].wordnum ) {
2149             Perl_re_printf( aTHX_  "%5s| ","");
2150         } else {
2151             Perl_re_printf( aTHX_  "W%4x| ",
2152                 trie->states[ state ].wordnum
2153             );
2154         }
2155         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2156             SV ** const tmp = av_fetch( revcharmap,
2157                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2158             if ( tmp ) {
2159                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2160                     colwidth,
2161                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2162                               colwidth,
2163                               PL_colors[0], PL_colors[1],
2164                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2165                               | PERL_PV_ESCAPE_FIRSTCHAR
2166                     ) ,
2167                     TRIE_LIST_ITEM(state,charid).forid,
2168                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2169                 );
2170                 if (!(charid % 10))
2171                     Perl_re_printf( aTHX_  "\n%*s| ",
2172                         (int)((depth * 2) + 14), "");
2173             }
2174         }
2175         Perl_re_printf( aTHX_  "\n");
2176     }
2177 }
2178
2179 /*
2180   Dumps a fully constructed but uncompressed trie in table form.
2181   This is the normal DFA style state transition table, with a few
2182   twists to facilitate compression later.
2183   Used for debugging make_trie().
2184 */
2185 STATIC void
2186 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2187                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2188                           U32 depth)
2189 {
2190     U32 state;
2191     U16 charid;
2192     SV *sv=sv_newmortal();
2193     int colwidth= widecharmap ? 6 : 4;
2194     GET_RE_DEBUG_FLAGS_DECL;
2195
2196     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2197
2198     /*
2199        print out the table precompression so that we can do a visual check
2200        that they are identical.
2201      */
2202
2203     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2204
2205     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2206         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2207         if ( tmp ) {
2208             Perl_re_printf( aTHX_  "%*s",
2209                 colwidth,
2210                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2211                             PL_colors[0], PL_colors[1],
2212                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2213                             PERL_PV_ESCAPE_FIRSTCHAR
2214                 )
2215             );
2216         }
2217     }
2218
2219     Perl_re_printf( aTHX_ "\n");
2220     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2221
2222     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2223         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2224     }
2225
2226     Perl_re_printf( aTHX_  "\n" );
2227
2228     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2229
2230         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2231             depth+1,
2232             (UV)TRIE_NODENUM( state ) );
2233
2234         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2235             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2236             if (v)
2237                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2238             else
2239                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2240         }
2241         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2242             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2243                                             (UV)trie->trans[ state ].check );
2244         } else {
2245             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2246                                             (UV)trie->trans[ state ].check,
2247             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2248         }
2249     }
2250 }
2251
2252 #endif
2253
2254
2255 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2256   startbranch: the first branch in the whole branch sequence
2257   first      : start branch of sequence of branch-exact nodes.
2258                May be the same as startbranch
2259   last       : Thing following the last branch.
2260                May be the same as tail.
2261   tail       : item following the branch sequence
2262   count      : words in the sequence
2263   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2264   depth      : indent depth
2265
2266 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2267
2268 A trie is an N'ary tree where the branches are determined by digital
2269 decomposition of the key. IE, at the root node you look up the 1st character and
2270 follow that branch repeat until you find the end of the branches. Nodes can be
2271 marked as "accepting" meaning they represent a complete word. Eg:
2272
2273   /he|she|his|hers/
2274
2275 would convert into the following structure. Numbers represent states, letters
2276 following numbers represent valid transitions on the letter from that state, if
2277 the number is in square brackets it represents an accepting state, otherwise it
2278 will be in parenthesis.
2279
2280       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2281       |    |
2282       |   (2)
2283       |    |
2284      (1)   +-i->(6)-+-s->[7]
2285       |
2286       +-s->(3)-+-h->(4)-+-e->[5]
2287
2288       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2289
2290 This shows that when matching against the string 'hers' we will begin at state 1
2291 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2292 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2293 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2294 single traverse. We store a mapping from accepting to state to which word was
2295 matched, and then when we have multiple possibilities we try to complete the
2296 rest of the regex in the order in which they occurred in the alternation.
2297
2298 The only prior NFA like behaviour that would be changed by the TRIE support is
2299 the silent ignoring of duplicate alternations which are of the form:
2300
2301  / (DUPE|DUPE) X? (?{ ... }) Y /x
2302
2303 Thus EVAL blocks following a trie may be called a different number of times with
2304 and without the optimisation. With the optimisations dupes will be silently
2305 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2306 the following demonstrates:
2307
2308  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2309
2310 which prints out 'word' three times, but
2311
2312  'words'=~/(word|word|word)(?{ print $1 })S/
2313
2314 which doesnt print it out at all. This is due to other optimisations kicking in.
2315
2316 Example of what happens on a structural level:
2317
2318 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2319
2320    1: CURLYM[1] {1,32767}(18)
2321    5:   BRANCH(8)
2322    6:     EXACT <ac>(16)
2323    8:   BRANCH(11)
2324    9:     EXACT <ad>(16)
2325   11:   BRANCH(14)
2326   12:     EXACT <ab>(16)
2327   16:   SUCCEED(0)
2328   17:   NOTHING(18)
2329   18: END(0)
2330
2331 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2332 and should turn into:
2333
2334    1: CURLYM[1] {1,32767}(18)
2335    5:   TRIE(16)
2336         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2337           <ac>
2338           <ad>
2339           <ab>
2340   16:   SUCCEED(0)
2341   17:   NOTHING(18)
2342   18: END(0)
2343
2344 Cases where tail != last would be like /(?foo|bar)baz/:
2345
2346    1: BRANCH(4)
2347    2:   EXACT <foo>(8)
2348    4: BRANCH(7)
2349    5:   EXACT <bar>(8)
2350    7: TAIL(8)
2351    8: EXACT <baz>(10)
2352   10: END(0)
2353
2354 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2355 and would end up looking like:
2356
2357     1: TRIE(8)
2358       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2359         <foo>
2360         <bar>
2361    7: TAIL(8)
2362    8: EXACT <baz>(10)
2363   10: END(0)
2364
2365     d = uvchr_to_utf8_flags(d, uv, 0);
2366
2367 is the recommended Unicode-aware way of saying
2368
2369     *(d++) = uv;
2370 */
2371
2372 #define TRIE_STORE_REVCHAR(val)                                            \
2373     STMT_START {                                                           \
2374         if (UTF) {                                                         \
2375             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2376             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2377             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2378             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2379             SvPOK_on(zlopp);                                               \
2380             SvUTF8_on(zlopp);                                              \
2381             av_push(revcharmap, zlopp);                                    \
2382         } else {                                                           \
2383             char ooooff = (char)val;                                           \
2384             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2385         }                                                                  \
2386         } STMT_END
2387
2388 /* This gets the next character from the input, folding it if not already
2389  * folded. */
2390 #define TRIE_READ_CHAR STMT_START {                                           \
2391     wordlen++;                                                                \
2392     if ( UTF ) {                                                              \
2393         /* if it is UTF then it is either already folded, or does not need    \
2394          * folding */                                                         \
2395         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2396     }                                                                         \
2397     else if (folder == PL_fold_latin1) {                                      \
2398         /* This folder implies Unicode rules, which in the range expressible  \
2399          *  by not UTF is the lower case, with the two exceptions, one of     \
2400          *  which should have been taken care of before calling this */       \
2401         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2402         uvc = toLOWER_L1(*uc);                                                \
2403         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2404         len = 1;                                                              \
2405     } else {                                                                  \
2406         /* raw data, will be folded later if needed */                        \
2407         uvc = (U32)*uc;                                                       \
2408         len = 1;                                                              \
2409     }                                                                         \
2410 } STMT_END
2411
2412
2413
2414 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2415     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2416         U32 ging = TRIE_LIST_LEN( state ) * 2;                  \
2417         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2418         TRIE_LIST_LEN( state ) = ging;                          \
2419     }                                                           \
2420     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2421     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2422     TRIE_LIST_CUR( state )++;                                   \
2423 } STMT_END
2424
2425 #define TRIE_LIST_NEW(state) STMT_START {                       \
2426     Newxz( trie->states[ state ].trans.list,               \
2427         4, reg_trie_trans_le );                                 \
2428      TRIE_LIST_CUR( state ) = 1;                                \
2429      TRIE_LIST_LEN( state ) = 4;                                \
2430 } STMT_END
2431
2432 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2433     U16 dupe= trie->states[ state ].wordnum;                    \
2434     regnode * const noper_next = regnext( noper );              \
2435                                                                 \
2436     DEBUG_r({                                                   \
2437         /* store the word for dumping */                        \
2438         SV* tmp;                                                \
2439         if (OP(noper) != NOTHING)                               \
2440             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2441         else                                                    \
2442             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2443         av_push( trie_words, tmp );                             \
2444     });                                                         \
2445                                                                 \
2446     curword++;                                                  \
2447     trie->wordinfo[curword].prev   = 0;                         \
2448     trie->wordinfo[curword].len    = wordlen;                   \
2449     trie->wordinfo[curword].accept = state;                     \
2450                                                                 \
2451     if ( noper_next < tail ) {                                  \
2452         if (!trie->jump)                                        \
2453             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2454                                                  sizeof(U16) ); \
2455         trie->jump[curword] = (U16)(noper_next - convert);      \
2456         if (!jumper)                                            \
2457             jumper = noper_next;                                \
2458         if (!nextbranch)                                        \
2459             nextbranch= regnext(cur);                           \
2460     }                                                           \
2461                                                                 \
2462     if ( dupe ) {                                               \
2463         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2464         /* chain, so that when the bits of chain are later    */\
2465         /* linked together, the dups appear in the chain      */\
2466         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2467         trie->wordinfo[dupe].prev = curword;                    \
2468     } else {                                                    \
2469         /* we haven't inserted this word yet.                */ \
2470         trie->states[ state ].wordnum = curword;                \
2471     }                                                           \
2472 } STMT_END
2473
2474
2475 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2476      ( ( base + charid >=  ucharcount                                   \
2477          && base + charid < ubound                                      \
2478          && state == trie->trans[ base - ucharcount + charid ].check    \
2479          && trie->trans[ base - ucharcount + charid ].next )            \
2480            ? trie->trans[ base - ucharcount + charid ].next             \
2481            : ( state==1 ? special : 0 )                                 \
2482       )
2483
2484 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2485 STMT_START {                                                \
2486     TRIE_BITMAP_SET(trie, uvc);                             \
2487     /* store the folded codepoint */                        \
2488     if ( folder )                                           \
2489         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2490                                                             \
2491     if ( !UTF ) {                                           \
2492         /* store first byte of utf8 representation of */    \
2493         /* variant codepoints */                            \
2494         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2495             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2496         }                                                   \
2497     }                                                       \
2498 } STMT_END
2499 #define MADE_TRIE       1
2500 #define MADE_JUMP_TRIE  2
2501 #define MADE_EXACT_TRIE 4
2502
2503 STATIC I32
2504 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2505                   regnode *first, regnode *last, regnode *tail,
2506                   U32 word_count, U32 flags, U32 depth)
2507 {
2508     /* first pass, loop through and scan words */
2509     reg_trie_data *trie;
2510     HV *widecharmap = NULL;
2511     AV *revcharmap = newAV();
2512     regnode *cur;
2513     STRLEN len = 0;
2514     UV uvc = 0;
2515     U16 curword = 0;
2516     U32 next_alloc = 0;
2517     regnode *jumper = NULL;
2518     regnode *nextbranch = NULL;
2519     regnode *convert = NULL;
2520     U32 *prev_states; /* temp array mapping each state to previous one */
2521     /* we just use folder as a flag in utf8 */
2522     const U8 * folder = NULL;
2523
2524     /* in the below add_data call we are storing either 'tu' or 'tuaa'
2525      * which stands for one trie structure, one hash, optionally followed
2526      * by two arrays */
2527 #ifdef DEBUGGING
2528     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuaa"));
2529     AV *trie_words = NULL;
2530     /* along with revcharmap, this only used during construction but both are
2531      * useful during debugging so we store them in the struct when debugging.
2532      */
2533 #else
2534     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2535     STRLEN trie_charcount=0;
2536 #endif
2537     SV *re_trie_maxbuff;
2538     GET_RE_DEBUG_FLAGS_DECL;
2539
2540     PERL_ARGS_ASSERT_MAKE_TRIE;
2541 #ifndef DEBUGGING
2542     PERL_UNUSED_ARG(depth);
2543 #endif
2544
2545     switch (flags) {
2546         case EXACT: case EXACTL: break;
2547         case EXACTFA:
2548         case EXACTFU_SS:
2549         case EXACTFU:
2550         case EXACTFLU8: folder = PL_fold_latin1; break;
2551         case EXACTF:  folder = PL_fold; break;
2552         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2553     }
2554
2555     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2556     trie->refcount = 1;
2557     trie->startstate = 1;
2558     trie->wordcount = word_count;
2559     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2560     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2561     if (flags == EXACT || flags == EXACTL)
2562         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2563     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2564                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2565
2566     DEBUG_r({
2567         trie_words = newAV();
2568     });
2569
2570     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2571     assert(re_trie_maxbuff);
2572     if (!SvIOK(re_trie_maxbuff)) {
2573         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2574     }
2575     DEBUG_TRIE_COMPILE_r({
2576         Perl_re_indentf( aTHX_
2577           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2578           depth+1,
2579           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2580           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2581     });
2582
2583    /* Find the node we are going to overwrite */
2584     if ( first == startbranch && OP( last ) != BRANCH ) {
2585         /* whole branch chain */
2586         convert = first;
2587     } else {
2588         /* branch sub-chain */
2589         convert = NEXTOPER( first );
2590     }
2591
2592     /*  -- First loop and Setup --
2593
2594        We first traverse the branches and scan each word to determine if it
2595        contains widechars, and how many unique chars there are, this is
2596        important as we have to build a table with at least as many columns as we
2597        have unique chars.
2598
2599        We use an array of integers to represent the character codes 0..255
2600        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2601        the native representation of the character value as the key and IV's for
2602        the coded index.
2603
2604        *TODO* If we keep track of how many times each character is used we can
2605        remap the columns so that the table compression later on is more
2606        efficient in terms of memory by ensuring the most common value is in the
2607        middle and the least common are on the outside.  IMO this would be better
2608        than a most to least common mapping as theres a decent chance the most
2609        common letter will share a node with the least common, meaning the node
2610        will not be compressible. With a middle is most common approach the worst
2611        case is when we have the least common nodes twice.
2612
2613      */
2614
2615     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2616         regnode *noper = NEXTOPER( cur );
2617         const U8 *uc;
2618         const U8 *e;
2619         int foldlen = 0;
2620         U32 wordlen      = 0;         /* required init */
2621         STRLEN minchars = 0;
2622         STRLEN maxchars = 0;
2623         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2624                                                bitmap?*/
2625
2626         if (OP(noper) == NOTHING) {
2627             /* skip past a NOTHING at the start of an alternation
2628              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2629              */
2630             regnode *noper_next= regnext(noper);
2631             if (noper_next < tail)
2632                 noper= noper_next;
2633         }
2634
2635         if ( noper < tail &&
2636                 (
2637                     OP(noper) == flags ||
2638                     (
2639                         flags == EXACTFU &&
2640                         OP(noper) == EXACTFU_SS
2641                     )
2642                 )
2643         ) {
2644             uc= (U8*)STRING(noper);
2645             e= uc + STR_LEN(noper);
2646         } else {
2647             trie->minlen= 0;
2648             continue;
2649         }
2650
2651
2652         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2653             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2654                                           regardless of encoding */
2655             if (OP( noper ) == EXACTFU_SS) {
2656                 /* false positives are ok, so just set this */
2657                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2658             }
2659         }
2660
2661         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2662                                            branch */
2663             TRIE_CHARCOUNT(trie)++;
2664             TRIE_READ_CHAR;
2665
2666             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2667              * is in effect.  Under /i, this character can match itself, or
2668              * anything that folds to it.  If not under /i, it can match just
2669              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2670              * all fold to k, and all are single characters.   But some folds
2671              * expand to more than one character, so for example LATIN SMALL
2672              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2673              * the string beginning at 'uc' is 'ffi', it could be matched by
2674              * three characters, or just by the one ligature character. (It
2675              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2676              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2677              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2678              * match.)  The trie needs to know the minimum and maximum number
2679              * of characters that could match so that it can use size alone to
2680              * quickly reject many match attempts.  The max is simple: it is
2681              * the number of folded characters in this branch (since a fold is
2682              * never shorter than what folds to it. */
2683
2684             maxchars++;
2685
2686             /* And the min is equal to the max if not under /i (indicated by
2687              * 'folder' being NULL), or there are no multi-character folds.  If
2688              * there is a multi-character fold, the min is incremented just
2689              * once, for the character that folds to the sequence.  Each
2690              * character in the sequence needs to be added to the list below of
2691              * characters in the trie, but we count only the first towards the
2692              * min number of characters needed.  This is done through the
2693              * variable 'foldlen', which is returned by the macros that look
2694              * for these sequences as the number of bytes the sequence
2695              * occupies.  Each time through the loop, we decrement 'foldlen' by
2696              * how many bytes the current char occupies.  Only when it reaches
2697              * 0 do we increment 'minchars' or look for another multi-character
2698              * sequence. */
2699             if (folder == NULL) {
2700                 minchars++;
2701             }
2702             else if (foldlen > 0) {
2703                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2704             }
2705             else {
2706                 minchars++;
2707
2708                 /* See if *uc is the beginning of a multi-character fold.  If
2709                  * so, we decrement the length remaining to look at, to account
2710                  * for the current character this iteration.  (We can use 'uc'
2711                  * instead of the fold returned by TRIE_READ_CHAR because for
2712                  * non-UTF, the latin1_safe macro is smart enough to account
2713                  * for all the unfolded characters, and because for UTF, the
2714                  * string will already have been folded earlier in the
2715                  * compilation process */
2716                 if (UTF) {
2717                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2718                         foldlen -= UTF8SKIP(uc);
2719                     }
2720                 }
2721                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2722                     foldlen--;
2723                 }
2724             }
2725
2726             /* The current character (and any potential folds) should be added
2727              * to the possible matching characters for this position in this
2728              * branch */
2729             if ( uvc < 256 ) {
2730                 if ( folder ) {
2731                     U8 folded= folder[ (U8) uvc ];
2732                     if ( !trie->charmap[ folded ] ) {
2733                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2734                         TRIE_STORE_REVCHAR( folded );
2735                     }
2736                 }
2737                 if ( !trie->charmap[ uvc ] ) {
2738                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2739                     TRIE_STORE_REVCHAR( uvc );
2740                 }
2741                 if ( set_bit ) {
2742                     /* store the codepoint in the bitmap, and its folded
2743                      * equivalent. */
2744                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2745                     set_bit = 0; /* We've done our bit :-) */
2746                 }
2747             } else {
2748
2749                 /* XXX We could come up with the list of code points that fold
2750                  * to this using PL_utf8_foldclosures, except not for
2751                  * multi-char folds, as there may be multiple combinations
2752                  * there that could work, which needs to wait until runtime to
2753                  * resolve (The comment about LIGATURE FFI above is such an
2754                  * example */
2755
2756                 SV** svpp;
2757                 if ( !widecharmap )
2758                     widecharmap = newHV();
2759
2760                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2761
2762                 if ( !svpp )
2763                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2764
2765                 if ( !SvTRUE( *svpp ) ) {
2766                     sv_setiv( *svpp, ++trie->uniquecharcount );
2767                     TRIE_STORE_REVCHAR(uvc);
2768                 }
2769             }
2770         } /* end loop through characters in this branch of the trie */
2771
2772         /* We take the min and max for this branch and combine to find the min
2773          * and max for all branches processed so far */
2774         if( cur == first ) {
2775             trie->minlen = minchars;
2776             trie->maxlen = maxchars;
2777         } else if (minchars < trie->minlen) {
2778             trie->minlen = minchars;
2779         } else if (maxchars > trie->maxlen) {
2780             trie->maxlen = maxchars;
2781         }
2782     } /* end first pass */
2783     DEBUG_TRIE_COMPILE_r(
2784         Perl_re_indentf( aTHX_
2785                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2786                 depth+1,
2787                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2788                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2789                 (int)trie->minlen, (int)trie->maxlen )
2790     );
2791
2792     /*
2793         We now know what we are dealing with in terms of unique chars and
2794         string sizes so we can calculate how much memory a naive
2795         representation using a flat table  will take. If it's over a reasonable
2796         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2797         conservative but potentially much slower representation using an array
2798         of lists.
2799
2800         At the end we convert both representations into the same compressed
2801         form that will be used in regexec.c for matching with. The latter
2802         is a form that cannot be used to construct with but has memory
2803         properties similar to the list form and access properties similar
2804         to the table form making it both suitable for fast searches and
2805         small enough that its feasable to store for the duration of a program.
2806
2807         See the comment in the code where the compressed table is produced
2808         inplace from the flat tabe representation for an explanation of how
2809         the compression works.
2810
2811     */
2812
2813
2814     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2815     prev_states[1] = 0;
2816
2817     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2818                                                     > SvIV(re_trie_maxbuff) )
2819     {
2820         /*
2821             Second Pass -- Array Of Lists Representation
2822
2823             Each state will be represented by a list of charid:state records
2824             (reg_trie_trans_le) the first such element holds the CUR and LEN
2825             points of the allocated array. (See defines above).
2826
2827             We build the initial structure using the lists, and then convert
2828             it into the compressed table form which allows faster lookups
2829             (but cant be modified once converted).
2830         */
2831
2832         STRLEN transcount = 1;
2833
2834         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2835             depth+1));
2836
2837         trie->states = (reg_trie_state *)
2838             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2839                                   sizeof(reg_trie_state) );
2840         TRIE_LIST_NEW(1);
2841         next_alloc = 2;
2842
2843         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2844
2845             regnode *noper   = NEXTOPER( cur );
2846             U32 state        = 1;         /* required init */
2847             U16 charid       = 0;         /* sanity init */
2848             U32 wordlen      = 0;         /* required init */
2849
2850             if (OP(noper) == NOTHING) {
2851                 regnode *noper_next= regnext(noper);
2852                 if (noper_next < tail)
2853                     noper= noper_next;
2854             }
2855
2856             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2857                 const U8 *uc= (U8*)STRING(noper);
2858                 const U8 *e= uc + STR_LEN(noper);
2859
2860                 for ( ; uc < e ; uc += len ) {
2861
2862                     TRIE_READ_CHAR;
2863
2864                     if ( uvc < 256 ) {
2865                         charid = trie->charmap[ uvc ];
2866                     } else {
2867                         SV** const svpp = hv_fetch( widecharmap,
2868                                                     (char*)&uvc,
2869                                                     sizeof( UV ),
2870                                                     0);
2871                         if ( !svpp ) {
2872                             charid = 0;
2873                         } else {
2874                             charid=(U16)SvIV( *svpp );
2875                         }
2876                     }
2877                     /* charid is now 0 if we dont know the char read, or
2878                      * nonzero if we do */
2879                     if ( charid ) {
2880
2881                         U16 check;
2882                         U32 newstate = 0;
2883
2884                         charid--;
2885                         if ( !trie->states[ state ].trans.list ) {
2886                             TRIE_LIST_NEW( state );
2887                         }
2888                         for ( check = 1;
2889                               check <= TRIE_LIST_USED( state );
2890                               check++ )
2891                         {
2892                             if ( TRIE_LIST_ITEM( state, check ).forid
2893                                                                     == charid )
2894                             {
2895                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2896                                 break;
2897                             }
2898                         }
2899                         if ( ! newstate ) {
2900                             newstate = next_alloc++;
2901                             prev_states[newstate] = state;
2902                             TRIE_LIST_PUSH( state, charid, newstate );
2903                             transcount++;
2904                         }
2905                         state = newstate;
2906                     } else {
2907                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2908                     }
2909                 }
2910             }
2911             TRIE_HANDLE_WORD(state);
2912
2913         } /* end second pass */
2914
2915         /* next alloc is the NEXT state to be allocated */
2916         trie->statecount = next_alloc;
2917         trie->states = (reg_trie_state *)
2918             PerlMemShared_realloc( trie->states,
2919                                    next_alloc
2920                                    * sizeof(reg_trie_state) );
2921
2922         /* and now dump it out before we compress it */
2923         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2924                                                          revcharmap, next_alloc,
2925                                                          depth+1)
2926         );
2927
2928         trie->trans = (reg_trie_trans *)
2929             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2930         {
2931             U32 state;
2932             U32 tp = 0;
2933             U32 zp = 0;
2934
2935
2936             for( state=1 ; state < next_alloc ; state ++ ) {
2937                 U32 base=0;
2938
2939                 /*
2940                 DEBUG_TRIE_COMPILE_MORE_r(
2941                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2942                 );
2943                 */
2944
2945                 if (trie->states[state].trans.list) {
2946                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2947                     U16 maxid=minid;
2948                     U16 idx;
2949
2950                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2951                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2952                         if ( forid < minid ) {
2953                             minid=forid;
2954                         } else if ( forid > maxid ) {
2955                             maxid=forid;
2956                         }
2957                     }
2958                     if ( transcount < tp + maxid - minid + 1) {
2959                         transcount *= 2;
2960                         trie->trans = (reg_trie_trans *)
2961                             PerlMemShared_realloc( trie->trans,
2962                                                      transcount
2963                                                      * sizeof(reg_trie_trans) );
2964                         Zero( trie->trans + (transcount / 2),
2965                               transcount / 2,
2966                               reg_trie_trans );
2967                     }
2968                     base = trie->uniquecharcount + tp - minid;
2969                     if ( maxid == minid ) {
2970                         U32 set = 0;
2971                         for ( ; zp < tp ; zp++ ) {
2972                             if ( ! trie->trans[ zp ].next ) {
2973                                 base = trie->uniquecharcount + zp - minid;
2974                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2975                                                                    1).newstate;
2976                                 trie->trans[ zp ].check = state;
2977                                 set = 1;
2978                                 break;
2979                             }
2980                         }
2981                         if ( !set ) {
2982                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2983                                                                    1).newstate;
2984                             trie->trans[ tp ].check = state;
2985                             tp++;
2986                             zp = tp;
2987                         }
2988                     } else {
2989                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2990                             const U32 tid = base
2991                                            - trie->uniquecharcount
2992                                            + TRIE_LIST_ITEM( state, idx ).forid;
2993                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2994                                                                 idx ).newstate;
2995                             trie->trans[ tid ].check = state;
2996                         }
2997                         tp += ( maxid - minid + 1 );
2998                     }
2999                     Safefree(trie->states[ state ].trans.list);
3000                 }
3001                 /*
3002                 DEBUG_TRIE_COMPILE_MORE_r(
3003                     Perl_re_printf( aTHX_  " base: %d\n",base);
3004                 );
3005                 */
3006                 trie->states[ state ].trans.base=base;
3007             }
3008             trie->lasttrans = tp + 1;
3009         }
3010     } else {
3011         /*
3012            Second Pass -- Flat Table Representation.
3013
3014            we dont use the 0 slot of either trans[] or states[] so we add 1 to
3015            each.  We know that we will need Charcount+1 trans at most to store
3016            the data (one row per char at worst case) So we preallocate both
3017            structures assuming worst case.
3018
3019            We then construct the trie using only the .next slots of the entry
3020            structs.
3021
3022            We use the .check field of the first entry of the node temporarily
3023            to make compression both faster and easier by keeping track of how
3024            many non zero fields are in the node.
3025
3026            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
3027            transition.
3028
3029            There are two terms at use here: state as a TRIE_NODEIDX() which is
3030            a number representing the first entry of the node, and state as a
3031            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
3032            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
3033            if there are 2 entrys per node. eg:
3034
3035              A B       A B
3036           1. 2 4    1. 3 7
3037           2. 0 3    3. 0 5
3038           3. 0 0    5. 0 0
3039           4. 0 0    7. 0 0
3040
3041            The table is internally in the right hand, idx form. However as we
3042            also have to deal with the states array which is indexed by nodenum
3043            we have to use TRIE_NODENUM() to convert.
3044
3045         */
3046         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
3047             depth+1));
3048
3049         trie->trans = (reg_trie_trans *)
3050             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
3051                                   * trie->uniquecharcount + 1,
3052                                   sizeof(reg_trie_trans) );
3053         trie->states = (reg_trie_state *)
3054             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
3055                                   sizeof(reg_trie_state) );
3056         next_alloc = trie->uniquecharcount + 1;
3057
3058
3059         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3060
3061             regnode *noper   = NEXTOPER( cur );
3062
3063             U32 state        = 1;         /* required init */
3064
3065             U16 charid       = 0;         /* sanity init */
3066             U32 accept_state = 0;         /* sanity init */
3067
3068             U32 wordlen      = 0;         /* required init */
3069
3070             if (OP(noper) == NOTHING) {
3071                 regnode *noper_next= regnext(noper);
3072                 if (noper_next < tail)
3073                     noper= noper_next;
3074             }
3075
3076             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3077                 const U8 *uc= (U8*)STRING(noper);
3078                 const U8 *e= uc + STR_LEN(noper);
3079
3080                 for ( ; uc < e ; uc += len ) {
3081
3082                     TRIE_READ_CHAR;
3083
3084                     if ( uvc < 256 ) {
3085                         charid = trie->charmap[ uvc ];
3086                     } else {
3087                         SV* const * const svpp = hv_fetch( widecharmap,
3088                                                            (char*)&uvc,
3089                                                            sizeof( UV ),
3090                                                            0);
3091                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3092                     }
3093                     if ( charid ) {
3094                         charid--;
3095                         if ( !trie->trans[ state + charid ].next ) {
3096                             trie->trans[ state + charid ].next = next_alloc;
3097                             trie->trans[ state ].check++;
3098                             prev_states[TRIE_NODENUM(next_alloc)]
3099                                     = TRIE_NODENUM(state);
3100                             next_alloc += trie->uniquecharcount;
3101                         }
3102                         state = trie->trans[ state + charid ].next;
3103                     } else {
3104                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3105                     }
3106                     /* charid is now 0 if we dont know the char read, or
3107                      * nonzero if we do */
3108                 }
3109             }
3110             accept_state = TRIE_NODENUM( state );
3111             TRIE_HANDLE_WORD(accept_state);
3112
3113         } /* end second pass */
3114
3115         /* and now dump it out before we compress it */
3116         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3117                                                           revcharmap,
3118                                                           next_alloc, depth+1));
3119
3120         {
3121         /*
3122            * Inplace compress the table.*
3123
3124            For sparse data sets the table constructed by the trie algorithm will
3125            be mostly 0/FAIL transitions or to put it another way mostly empty.
3126            (Note that leaf nodes will not contain any transitions.)
3127
3128            This algorithm compresses the tables by eliminating most such
3129            transitions, at the cost of a modest bit of extra work during lookup:
3130
3131            - Each states[] entry contains a .base field which indicates the
3132            index in the state[] array wheres its transition data is stored.
3133
3134            - If .base is 0 there are no valid transitions from that node.
3135
3136            - If .base is nonzero then charid is added to it to find an entry in
3137            the trans array.
3138
3139            -If trans[states[state].base+charid].check!=state then the
3140            transition is taken to be a 0/Fail transition. Thus if there are fail
3141            transitions at the front of the node then the .base offset will point
3142            somewhere inside the previous nodes data (or maybe even into a node
3143            even earlier), but the .check field determines if the transition is
3144            valid.
3145
3146            XXX - wrong maybe?
3147            The following process inplace converts the table to the compressed
3148            table: We first do not compress the root node 1,and mark all its
3149            .check pointers as 1 and set its .base pointer as 1 as well. This
3150            allows us to do a DFA construction from the compressed table later,
3151            and ensures that any .base pointers we calculate later are greater
3152            than 0.
3153
3154            - We set 'pos' to indicate the first entry of the second node.
3155
3156            - We then iterate over the columns of the node, finding the first and
3157            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3158            and set the .check pointers accordingly, and advance pos
3159            appropriately and repreat for the next node. Note that when we copy
3160            the next pointers we have to convert them from the original
3161            NODEIDX form to NODENUM form as the former is not valid post
3162            compression.
3163
3164            - If a node has no transitions used we mark its base as 0 and do not
3165            advance the pos pointer.
3166
3167            - If a node only has one transition we use a second pointer into the
3168            structure to fill in allocated fail transitions from other states.
3169            This pointer is independent of the main pointer and scans forward
3170            looking for null transitions that are allocated to a state. When it
3171            finds one it writes the single transition into the "hole".  If the
3172            pointer doesnt find one the single transition is appended as normal.
3173
3174            - Once compressed we can Renew/realloc the structures to release the
3175            excess space.
3176
3177            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3178            specifically Fig 3.47 and the associated pseudocode.
3179
3180            demq
3181         */
3182         const U32 laststate = TRIE_NODENUM( next_alloc );
3183         U32 state, charid;
3184         U32 pos = 0, zp=0;
3185         trie->statecount = laststate;
3186
3187         for ( state = 1 ; state < laststate ; state++ ) {
3188             U8 flag = 0;
3189             const U32 stateidx = TRIE_NODEIDX( state );
3190             const U32 o_used = trie->trans[ stateidx ].check;
3191             U32 used = trie->trans[ stateidx ].check;
3192             trie->trans[ stateidx ].check = 0;
3193
3194             for ( charid = 0;
3195                   used && charid < trie->uniquecharcount;
3196                   charid++ )
3197             {
3198                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3199                     if ( trie->trans[ stateidx + charid ].next ) {
3200                         if (o_used == 1) {
3201                             for ( ; zp < pos ; zp++ ) {
3202                                 if ( ! trie->trans[ zp ].next ) {
3203                                     break;
3204                                 }
3205                             }
3206                             trie->states[ state ].trans.base
3207                                                     = zp
3208                                                       + trie->uniquecharcount
3209                                                       - charid ;
3210                             trie->trans[ zp ].next
3211                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3212                                                              + charid ].next );
3213                             trie->trans[ zp ].check = state;
3214                             if ( ++zp > pos ) pos = zp;
3215                             break;
3216                         }
3217                         used--;
3218                     }
3219                     if ( !flag ) {
3220                         flag = 1;
3221                         trie->states[ state ].trans.base
3222                                        = pos + trie->uniquecharcount - charid ;
3223                     }
3224                     trie->trans[ pos ].next
3225                         = SAFE_TRIE_NODENUM(
3226                                        trie->trans[ stateidx + charid ].next );
3227                     trie->trans[ pos ].check = state;
3228                     pos++;
3229                 }
3230             }
3231         }
3232         trie->lasttrans = pos + 1;
3233         trie->states = (reg_trie_state *)
3234             PerlMemShared_realloc( trie->states, laststate
3235                                    * sizeof(reg_trie_state) );
3236         DEBUG_TRIE_COMPILE_MORE_r(
3237             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3238                 depth+1,
3239                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3240                        + 1 ),
3241                 (IV)next_alloc,
3242                 (IV)pos,
3243                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3244             );
3245
3246         } /* end table compress */
3247     }
3248     DEBUG_TRIE_COMPILE_MORE_r(
3249             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3250                 depth+1,
3251                 (UV)trie->statecount,
3252                 (UV)trie->lasttrans)
3253     );
3254     /* resize the trans array to remove unused space */
3255     trie->trans = (reg_trie_trans *)
3256         PerlMemShared_realloc( trie->trans, trie->lasttrans
3257                                * sizeof(reg_trie_trans) );
3258
3259     {   /* Modify the program and insert the new TRIE node */
3260         U8 nodetype =(U8)(flags & 0xFF);
3261         char *str=NULL;
3262
3263 #ifdef DEBUGGING
3264         regnode *optimize = NULL;
3265 #ifdef RE_TRACK_PATTERN_OFFSETS
3266
3267         U32 mjd_offset = 0;
3268         U32 mjd_nodelen = 0;
3269 #endif /* RE_TRACK_PATTERN_OFFSETS */
3270 #endif /* DEBUGGING */
3271         /*
3272            This means we convert either the first branch or the first Exact,
3273            depending on whether the thing following (in 'last') is a branch
3274            or not and whther first is the startbranch (ie is it a sub part of
3275            the alternation or is it the whole thing.)
3276            Assuming its a sub part we convert the EXACT otherwise we convert
3277            the whole branch sequence, including the first.
3278          */
3279         /* Find the node we are going to overwrite */
3280         if ( first != startbranch || OP( last ) == BRANCH ) {
3281             /* branch sub-chain */
3282             NEXT_OFF( first ) = (U16)(last - first);
3283 #ifdef RE_TRACK_PATTERN_OFFSETS
3284             DEBUG_r({
3285                 mjd_offset= Node_Offset((convert));
3286                 mjd_nodelen= Node_Length((convert));
3287             });
3288 #endif
3289             /* whole branch chain */
3290         }
3291 #ifdef RE_TRACK_PATTERN_OFFSETS
3292         else {
3293             DEBUG_r({
3294                 const  regnode *nop = NEXTOPER( convert );
3295                 mjd_offset= Node_Offset((nop));
3296                 mjd_nodelen= Node_Length((nop));
3297             });
3298         }
3299         DEBUG_OPTIMISE_r(
3300             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3301                 depth+1,
3302                 (UV)mjd_offset, (UV)mjd_nodelen)
3303         );
3304 #endif
3305         /* But first we check to see if there is a common prefix we can
3306            split out as an EXACT and put in front of the TRIE node.  */
3307         trie->startstate= 1;
3308         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3309             /* we want to find the first state that has more than
3310              * one transition, if that state is not the first state
3311              * then we have a common prefix which we can remove.
3312              */
3313             U32 state;
3314             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3315                 U32 ofs = 0;
3316                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3317                                        transition, -1 means none */
3318                 U32 count = 0;
3319                 const U32 base = trie->states[ state ].trans.base;
3320
3321                 /* does this state terminate an alternation? */
3322                 if ( trie->states[state].wordnum )
3323                         count = 1;
3324
3325                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3326                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3327                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3328                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3329                     {
3330                         if ( ++count > 1 ) {
3331                             /* we have more than one transition */
3332                             SV **tmp;
3333                             U8 *ch;
3334                             /* if this is the first state there is no common prefix
3335                              * to extract, so we can exit */
3336                             if ( state == 1 ) break;
3337                             tmp = av_fetch( revcharmap, ofs, 0);
3338                             ch = (U8*)SvPV_nolen_const( *tmp );
3339
3340                             /* if we are on count 2 then we need to initialize the
3341                              * bitmap, and store the previous char if there was one
3342                              * in it*/
3343                             if ( count == 2 ) {
3344                                 /* clear the bitmap */
3345                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3346                                 DEBUG_OPTIMISE_r(
3347                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3348                                         depth+1,
3349                                         (UV)state));
3350                                 if (first_ofs >= 0) {
3351                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3352                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3353
3354                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3355                                     DEBUG_OPTIMISE_r(
3356                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3357                                     );
3358                                 }
3359                             }
3360                             /* store the current firstchar in the bitmap */
3361                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3362                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3363                         }
3364                         first_ofs = ofs;
3365                     }
3366                 }
3367                 if ( count == 1 ) {
3368                     /* This state has only one transition, its transition is part
3369                      * of a common prefix - we need to concatenate the char it
3370                      * represents to what we have so far. */
3371                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3372                     STRLEN len;
3373                     char *ch = SvPV( *tmp, len );
3374                     DEBUG_OPTIMISE_r({
3375                         SV *sv=sv_newmortal();
3376                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3377                             depth+1,
3378                             (UV)state, (UV)first_ofs,
3379                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3380                                 PL_colors[0], PL_colors[1],
3381                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3382                                 PERL_PV_ESCAPE_FIRSTCHAR
3383                             )
3384                         );
3385                     });
3386                     if ( state==1 ) {
3387                         OP( convert ) = nodetype;
3388                         str=STRING(convert);
3389                         STR_LEN(convert)=0;
3390                     }
3391                     STR_LEN(convert) += len;
3392                     while (len--)
3393                         *str++ = *ch++;
3394                 } else {
3395 #ifdef DEBUGGING
3396                     if (state>1)
3397                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3398 #endif
3399                     break;
3400                 }
3401             }
3402             trie->prefixlen = (state-1);
3403             if (str) {
3404                 regnode *n = convert+NODE_SZ_STR(convert);
3405                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3406                 trie->startstate = state;
3407                 trie->minlen -= (state - 1);
3408                 trie->maxlen -= (state - 1);
3409 #ifdef DEBUGGING
3410                /* At least the UNICOS C compiler choked on this
3411                 * being argument to DEBUG_r(), so let's just have
3412                 * it right here. */
3413                if (
3414 #ifdef PERL_EXT_RE_BUILD
3415                    1
3416 #else
3417                    DEBUG_r_TEST
3418 #endif
3419                    ) {
3420                    regnode *fix = convert;
3421                    U32 word = trie->wordcount;
3422                    mjd_nodelen++;
3423                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3424                    while( ++fix < n ) {
3425                        Set_Node_Offset_Length(fix, 0, 0);
3426                    }
3427                    while (word--) {
3428                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3429                        if (tmp) {
3430                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3431                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3432                            else
3433                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3434                        }
3435                    }
3436                }
3437 #endif
3438                 if (trie->maxlen) {
3439                     convert = n;
3440                 } else {
3441                     NEXT_OFF(convert) = (U16)(tail - convert);
3442                     DEBUG_r(optimize= n);
3443                 }
3444             }
3445         }
3446         if (!jumper)
3447             jumper = last;
3448         if ( trie->maxlen ) {
3449             NEXT_OFF( convert ) = (U16)(tail - convert);
3450             ARG_SET( convert, data_slot );
3451             /* Store the offset to the first unabsorbed branch in
3452                jump[0], which is otherwise unused by the jump logic.
3453                We use this when dumping a trie and during optimisation. */
3454             if (trie->jump)
3455                 trie->jump[0] = (U16)(nextbranch - convert);
3456
3457             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3458              *   and there is a bitmap
3459              *   and the first "jump target" node we found leaves enough room
3460              * then convert the TRIE node into a TRIEC node, with the bitmap
3461              * embedded inline in the opcode - this is hypothetically faster.
3462              */
3463             if ( !trie->states[trie->startstate].wordnum
3464                  && trie->bitmap
3465                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3466             {
3467                 OP( convert ) = TRIEC;
3468                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3469                 PerlMemShared_free(trie->bitmap);
3470                 trie->bitmap= NULL;
3471             } else
3472                 OP( convert ) = TRIE;
3473
3474             /* store the type in the flags */
3475             convert->flags = nodetype;
3476             DEBUG_r({
3477             optimize = convert
3478                       + NODE_STEP_REGNODE
3479                       + regarglen[ OP( convert ) ];
3480             });
3481             /* XXX We really should free up the resource in trie now,
3482                    as we won't use them - (which resources?) dmq */
3483         }
3484         /* needed for dumping*/
3485         DEBUG_r(if (optimize) {
3486             regnode *opt = convert;
3487
3488             while ( ++opt < optimize) {
3489                 Set_Node_Offset_Length(opt,0,0);
3490             }
3491             /*
3492                 Try to clean up some of the debris left after the
3493                 optimisation.
3494              */
3495             while( optimize < jumper ) {
3496                 mjd_nodelen += Node_Length((optimize));
3497                 OP( optimize ) = OPTIMIZED;
3498                 Set_Node_Offset_Length(optimize,0,0);
3499                 optimize++;
3500             }
3501             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3502         });
3503     } /* end node insert */
3504
3505     /*  Finish populating the prev field of the wordinfo array.  Walk back
3506      *  from each accept state until we find another accept state, and if
3507      *  so, point the first word's .prev field at the second word. If the
3508      *  second already has a .prev field set, stop now. This will be the
3509      *  case either if we've already processed that word's accept state,
3510      *  or that state had multiple words, and the overspill words were
3511      *  already linked up earlier.
3512      */
3513     {
3514         U16 word;
3515         U32 state;
3516         U16 prev;
3517
3518         for (word=1; word <= trie->wordcount; word++) {
3519             prev = 0;
3520             if (trie->wordinfo[word].prev)
3521                 continue;
3522             state = trie->wordinfo[word].accept;
3523             while (state) {
3524                 state = prev_states[state];
3525                 if (!state)
3526                     break;
3527                 prev = trie->states[state].wordnum;
3528                 if (prev)
3529                     break;
3530             }
3531             trie->wordinfo[word].prev = prev;
3532         }
3533         Safefree(prev_states);
3534     }
3535
3536
3537     /* and now dump out the compressed format */
3538     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3539
3540     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3541 #ifdef DEBUGGING
3542     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3543     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3544 #else
3545     SvREFCNT_dec_NN(revcharmap);
3546 #endif
3547     return trie->jump
3548            ? MADE_JUMP_TRIE
3549            : trie->startstate>1
3550              ? MADE_EXACT_TRIE
3551              : MADE_TRIE;
3552 }
3553
3554 STATIC regnode *
3555 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3556 {
3557 /* The Trie is constructed and compressed now so we can build a fail array if
3558  * it's needed
3559
3560    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3561    3.32 in the
3562    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3563    Ullman 1985/88
3564    ISBN 0-201-10088-6
3565
3566    We find the fail state for each state in the trie, this state is the longest
3567    proper suffix of the current state's 'word' that is also a proper prefix of
3568    another word in our trie. State 1 represents the word '' and is thus the
3569    default fail state. This allows the DFA not to have to restart after its
3570    tried and failed a word at a given point, it simply continues as though it
3571    had been matching the other word in the first place.
3572    Consider
3573       'abcdgu'=~/abcdefg|cdgu/
3574    When we get to 'd' we are still matching the first word, we would encounter
3575    'g' which would fail, which would bring us to the state representing 'd' in
3576    the second word where we would try 'g' and succeed, proceeding to match
3577    'cdgu'.
3578  */
3579  /* add a fail transition */
3580     const U32 trie_offset = ARG(source);
3581     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3582     U32 *q;
3583     const U32 ucharcount = trie->uniquecharcount;
3584     const U32 numstates = trie->statecount;
3585     const U32 ubound = trie->lasttrans + ucharcount;
3586     U32 q_read = 0;
3587     U32 q_write = 0;
3588     U32 charid;
3589     U32 base = trie->states[ 1 ].trans.base;
3590     U32 *fail;
3591     reg_ac_data *aho;
3592     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3593     regnode *stclass;
3594     GET_RE_DEBUG_FLAGS_DECL;
3595
3596     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3597     PERL_UNUSED_CONTEXT;
3598 #ifndef DEBUGGING
3599     PERL_UNUSED_ARG(depth);
3600 #endif
3601
3602     if ( OP(source) == TRIE ) {
3603         struct regnode_1 *op = (struct regnode_1 *)
3604             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3605         StructCopy(source,op,struct regnode_1);
3606         stclass = (regnode *)op;
3607     } else {
3608         struct regnode_charclass *op = (struct regnode_charclass *)
3609             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3610         StructCopy(source,op,struct regnode_charclass);
3611         stclass = (regnode *)op;
3612     }
3613     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3614
3615     ARG_SET( stclass, data_slot );
3616     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3617     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3618     aho->trie=trie_offset;
3619     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3620     Copy( trie->states, aho->states, numstates, reg_trie_state );
3621     Newxz( q, numstates, U32);
3622     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3623     aho->refcount = 1;
3624     fail = aho->fail;
3625     /* initialize fail[0..1] to be 1 so that we always have
3626        a valid final fail state */
3627     fail[ 0 ] = fail[ 1 ] = 1;
3628
3629     for ( charid = 0; charid < ucharcount ; charid++ ) {
3630         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3631         if ( newstate ) {
3632             q[ q_write ] = newstate;
3633             /* set to point at the root */
3634             fail[ q[ q_write++ ] ]=1;
3635         }
3636     }
3637     while ( q_read < q_write) {
3638         const U32 cur = q[ q_read++ % numstates ];
3639         base = trie->states[ cur ].trans.base;
3640
3641         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3642             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3643             if (ch_state) {
3644                 U32 fail_state = cur;
3645                 U32 fail_base;
3646                 do {
3647                     fail_state = fail[ fail_state ];
3648                     fail_base = aho->states[ fail_state ].trans.base;
3649                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3650
3651                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3652                 fail[ ch_state ] = fail_state;
3653                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3654                 {
3655                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3656                 }
3657                 q[ q_write++ % numstates] = ch_state;
3658             }
3659         }
3660     }
3661     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3662        when we fail in state 1, this allows us to use the
3663        charclass scan to find a valid start char. This is based on the principle
3664        that theres a good chance the string being searched contains lots of stuff
3665        that cant be a start char.
3666      */
3667     fail[ 0 ] = fail[ 1 ] = 0;
3668     DEBUG_TRIE_COMPILE_r({
3669         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3670                       depth, (UV)numstates
3671         );
3672         for( q_read=1; q_read<numstates; q_read++ ) {
3673             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3674         }
3675         Perl_re_printf( aTHX_  "\n");
3676     });
3677     Safefree(q);
3678     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3679     return stclass;
3680 }
3681
3682
3683 /* The below joins as many adjacent EXACTish nodes as possible into a single
3684  * one.  The regop may be changed if the node(s) contain certain sequences that
3685  * require special handling.  The joining is only done if:
3686  * 1) there is room in the current conglomerated node to entirely contain the
3687  *    next one.
3688  * 2) they are the exact same node type
3689  *
3690  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3691  * these get optimized out
3692  *
3693  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3694  * as possible, even if that means splitting an existing node so that its first
3695  * part is moved to the preceeding node.  This would maximise the efficiency of
3696  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3697  * EXACTFish nodes into portions that don't change under folding vs those that
3698  * do.  Those portions that don't change may be the only things in the pattern that
3699  * could be used to find fixed and floating strings.
3700  *
3701  * If a node is to match under /i (folded), the number of characters it matches
3702  * can be different than its character length if it contains a multi-character
3703  * fold.  *min_subtract is set to the total delta number of characters of the
3704  * input nodes.
3705  *
3706  * And *unfolded_multi_char is set to indicate whether or not the node contains
3707  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3708  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3709  * SMALL LETTER SHARP S, as only if the target string being matched against
3710  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3711  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3712  * whose components are all above the Latin1 range are not run-time locale
3713  * dependent, and have already been folded by the time this function is
3714  * called.)
3715  *
3716  * This is as good a place as any to discuss the design of handling these
3717  * multi-character fold sequences.  It's been wrong in Perl for a very long
3718  * time.  There are three code points in Unicode whose multi-character folds
3719  * were long ago discovered to mess things up.  The previous designs for
3720  * dealing with these involved assigning a special node for them.  This
3721  * approach doesn't always work, as evidenced by this example:
3722  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3723  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3724  * would match just the \xDF, it won't be able to handle the case where a
3725  * successful match would have to cross the node's boundary.  The new approach
3726  * that hopefully generally solves the problem generates an EXACTFU_SS node
3727  * that is "sss" in this case.
3728  *
3729  * It turns out that there are problems with all multi-character folds, and not
3730  * just these three.  Now the code is general, for all such cases.  The
3731  * approach taken is:
3732  * 1)   This routine examines each EXACTFish node that could contain multi-
3733  *      character folded sequences.  Since a single character can fold into
3734  *      such a sequence, the minimum match length for this node is less than
3735  *      the number of characters in the node.  This routine returns in
3736  *      *min_subtract how many characters to subtract from the the actual
3737  *      length of the string to get a real minimum match length; it is 0 if
3738  *      there are no multi-char foldeds.  This delta is used by the caller to
3739  *      adjust the min length of the match, and the delta between min and max,
3740  *      so that the optimizer doesn't reject these possibilities based on size
3741  *      constraints.
3742  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3743  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3744  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3745  *      there is a possible fold length change.  That means that a regular
3746  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3747  *      with length changes, and so can be processed faster.  regexec.c takes
3748  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3749  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3750  *      known until runtime).  This saves effort in regex matching.  However,
3751  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3752  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3753  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3754  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3755  *      possibilities for the non-UTF8 patterns are quite simple, except for
3756  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3757  *      members of a fold-pair, and arrays are set up for all of them so that
3758  *      the other member of the pair can be found quickly.  Code elsewhere in
3759  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3760  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3761  *      described in the next item.
3762  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3763  *      validity of the fold won't be known until runtime, and so must remain
3764  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3765  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3766  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3767  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3768  *      The reason this is a problem is that the optimizer part of regexec.c
3769  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3770  *      that a character in the pattern corresponds to at most a single
3771  *      character in the target string.  (And I do mean character, and not byte
3772  *      here, unlike other parts of the documentation that have never been
3773  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3774  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3775  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3776  *      nodes, violate the assumption, and they are the only instances where it
3777  *      is violated.  I'm reluctant to try to change the assumption, as the
3778  *      code involved is impenetrable to me (khw), so instead the code here
3779  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3780  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3781  *      boolean indicating whether or not the node contains such a fold.  When
3782  *      it is true, the caller sets a flag that later causes the optimizer in
3783  *      this file to not set values for the floating and fixed string lengths,
3784  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3785  *      assumption.  Thus, there is no optimization based on string lengths for
3786  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3787  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3788  *      assumption is wrong only in these cases is that all other non-UTF-8
3789  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3790  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3791  *      EXACTF nodes because we don't know at compile time if it actually
3792  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3793  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3794  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3795  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3796  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3797  *      string would require the pattern to be forced into UTF-8, the overhead
3798  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3799  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3800  *      locale.)
3801  *
3802  *      Similarly, the code that generates tries doesn't currently handle
3803  *      not-already-folded multi-char folds, and it looks like a pain to change
3804  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3805  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3806  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3807  *      using /iaa matching will be doing so almost entirely with ASCII
3808  *      strings, so this should rarely be encountered in practice */
3809
3810 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3811     if (PL_regkind[OP(scan)] == EXACT) \
3812         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3813
3814 STATIC U32
3815 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3816                    UV *min_subtract, bool *unfolded_multi_char,
3817                    U32 flags,regnode *val, U32 depth)
3818 {
3819     /* Merge several consecutive EXACTish nodes into one. */
3820     regnode *n = regnext(scan);
3821     U32 stringok = 1;
3822     regnode *next = scan + NODE_SZ_STR(scan);
3823     U32 merged = 0;
3824     U32 stopnow = 0;
3825 #ifdef DEBUGGING
3826     regnode *stop = scan;
3827     GET_RE_DEBUG_FLAGS_DECL;
3828 #else
3829     PERL_UNUSED_ARG(depth);
3830 #endif
3831
3832     PERL_ARGS_ASSERT_JOIN_EXACT;
3833 #ifndef EXPERIMENTAL_INPLACESCAN
3834     PERL_UNUSED_ARG(flags);
3835     PERL_UNUSED_ARG(val);
3836 #endif
3837     DEBUG_PEEP("join", scan, depth, 0);
3838
3839     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3840      * EXACT ones that are mergeable to the current one. */
3841     while (n
3842            && (PL_regkind[OP(n)] == NOTHING
3843                || (stringok && OP(n) == OP(scan)))
3844            && NEXT_OFF(n)
3845            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3846     {
3847
3848         if (OP(n) == TAIL || n > next)
3849             stringok = 0;
3850         if (PL_regkind[OP(n)] == NOTHING) {
3851             DEBUG_PEEP("skip:", n, depth, 0);
3852             NEXT_OFF(scan) += NEXT_OFF(n);
3853             next = n + NODE_STEP_REGNODE;
3854 #ifdef DEBUGGING
3855             if (stringok)
3856                 stop = n;
3857 #endif
3858             n = regnext(n);
3859         }
3860         else if (stringok) {
3861             const unsigned int oldl = STR_LEN(scan);
3862             regnode * const nnext = regnext(n);
3863
3864             /* XXX I (khw) kind of doubt that this works on platforms (should
3865              * Perl ever run on one) where U8_MAX is above 255 because of lots
3866              * of other assumptions */
3867             /* Don't join if the sum can't fit into a single node */
3868             if (oldl + STR_LEN(n) > U8_MAX)
3869                 break;
3870
3871             DEBUG_PEEP("merg", n, depth, 0);
3872             merged++;
3873
3874             NEXT_OFF(scan) += NEXT_OFF(n);
3875             STR_LEN(scan) += STR_LEN(n);
3876             next = n + NODE_SZ_STR(n);
3877             /* Now we can overwrite *n : */
3878             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3879 #ifdef DEBUGGING
3880             stop = next - 1;
3881 #endif
3882             n = nnext;
3883             if (stopnow) break;
3884         }
3885
3886 #ifdef EXPERIMENTAL_INPLACESCAN
3887         if (flags && !NEXT_OFF(n)) {
3888             DEBUG_PEEP("atch", val, depth, 0);
3889             if (reg_off_by_arg[OP(n)]) {
3890                 ARG_SET(n, val - n);
3891             }
3892             else {
3893                 NEXT_OFF(n) = val - n;
3894             }
3895             stopnow = 1;
3896         }
3897 #endif
3898     }
3899
3900     *min_subtract = 0;
3901     *unfolded_multi_char = FALSE;
3902
3903     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3904      * can now analyze for sequences of problematic code points.  (Prior to
3905      * this final joining, sequences could have been split over boundaries, and
3906      * hence missed).  The sequences only happen in folding, hence for any
3907      * non-EXACT EXACTish node */
3908     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3909         U8* s0 = (U8*) STRING(scan);
3910         U8* s = s0;
3911         U8* s_end = s0 + STR_LEN(scan);
3912
3913         int total_count_delta = 0;  /* Total delta number of characters that
3914                                        multi-char folds expand to */
3915
3916         /* One pass is made over the node's string looking for all the
3917          * possibilities.  To avoid some tests in the loop, there are two main
3918          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3919          * non-UTF-8 */
3920         if (UTF) {
3921             U8* folded = NULL;
3922
3923             if (OP(scan) == EXACTFL) {
3924                 U8 *d;
3925
3926                 /* An EXACTFL node would already have been changed to another
3927                  * node type unless there is at least one character in it that
3928                  * is problematic; likely a character whose fold definition
3929                  * won't be known until runtime, and so has yet to be folded.
3930                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3931                  * to handle the UTF-8 case, we need to create a temporary
3932                  * folded copy using UTF-8 locale rules in order to analyze it.
3933                  * This is because our macros that look to see if a sequence is
3934                  * a multi-char fold assume everything is folded (otherwise the
3935                  * tests in those macros would be too complicated and slow).
3936                  * Note that here, the non-problematic folds will have already
3937                  * been done, so we can just copy such characters.  We actually
3938                  * don't completely fold the EXACTFL string.  We skip the
3939                  * unfolded multi-char folds, as that would just create work
3940                  * below to figure out the size they already are */
3941
3942                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3943                 d = folded;
3944                 while (s < s_end) {
3945                     STRLEN s_len = UTF8SKIP(s);
3946                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3947                         Copy(s, d, s_len, U8);
3948                         d += s_len;
3949                     }
3950                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3951                         *unfolded_multi_char = TRUE;
3952                         Copy(s, d, s_len, U8);
3953                         d += s_len;
3954                     }
3955                     else if (isASCII(*s)) {
3956                         *(d++) = toFOLD(*s);
3957                     }
3958                     else {
3959                         STRLEN len;
3960                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
3961                         d += len;
3962                     }
3963                     s += s_len;
3964                 }
3965
3966                 /* Point the remainder of the routine to look at our temporary
3967                  * folded copy */
3968                 s = folded;
3969                 s_end = d;
3970             } /* End of creating folded copy of EXACTFL string */
3971
3972             /* Examine the string for a multi-character fold sequence.  UTF-8
3973              * patterns have all characters pre-folded by the time this code is
3974              * executed */
3975             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3976                                      length sequence we are looking for is 2 */
3977             {
3978                 int count = 0;  /* How many characters in a multi-char fold */
3979                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3980                 if (! len) {    /* Not a multi-char fold: get next char */
3981                     s += UTF8SKIP(s);
3982                     continue;
3983                 }
3984
3985                 /* Nodes with 'ss' require special handling, except for
3986                  * EXACTFA-ish for which there is no multi-char fold to this */
3987                 if (len == 2 && *s == 's' && *(s+1) == 's'
3988                     && OP(scan) != EXACTFA
3989                     && OP(scan) != EXACTFA_NO_TRIE)
3990                 {
3991                     count = 2;
3992                     if (OP(scan) != EXACTFL) {
3993                         OP(scan) = EXACTFU_SS;
3994                     }
3995                     s += 2;
3996                 }
3997                 else { /* Here is a generic multi-char fold. */
3998                     U8* multi_end  = s + len;
3999
4000                     /* Count how many characters are in it.  In the case of
4001                      * /aa, no folds which contain ASCII code points are
4002                      * allowed, so check for those, and skip if found. */
4003                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
4004                         count = utf8_length(s, multi_end);
4005                         s = multi_end;
4006                     }
4007                     else {
4008                         while (s < multi_end) {
4009                             if (isASCII(*s)) {
4010                                 s++;
4011                                 goto next_iteration;
4012                             }
4013                             else {
4014                                 s += UTF8SKIP(s);
4015                             }
4016                             count++;
4017                         }
4018                     }
4019                 }
4020
4021                 /* The delta is how long the sequence is minus 1 (1 is how long
4022                  * the character that folds to the sequence is) */
4023                 total_count_delta += count - 1;
4024               next_iteration: ;
4025             }
4026
4027             /* We created a temporary folded copy of the string in EXACTFL
4028              * nodes.  Therefore we need to be sure it doesn't go below zero,
4029              * as the real string could be shorter */
4030             if (OP(scan) == EXACTFL) {
4031                 int total_chars = utf8_length((U8*) STRING(scan),
4032                                            (U8*) STRING(scan) + STR_LEN(scan));
4033                 if (total_count_delta > total_chars) {
4034                     total_count_delta = total_chars;
4035                 }
4036             }
4037
4038             *min_subtract += total_count_delta;
4039             Safefree(folded);
4040         }
4041         else if (OP(scan) == EXACTFA) {
4042
4043             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
4044              * fold to the ASCII range (and there are no existing ones in the
4045              * upper latin1 range).  But, as outlined in the comments preceding
4046              * this function, we need to flag any occurrences of the sharp s.
4047              * This character forbids trie formation (because of added
4048              * complexity) */
4049 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4050    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4051                                       || UNICODE_DOT_DOT_VERSION > 0)
4052             while (s < s_end) {
4053                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4054                     OP(scan) = EXACTFA_NO_TRIE;
4055                     *unfolded_multi_char = TRUE;
4056                     break;
4057                 }
4058                 s++;
4059             }
4060         }
4061         else {
4062
4063             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
4064              * folds that are all Latin1.  As explained in the comments
4065              * preceding this function, we look also for the sharp s in EXACTF
4066              * and EXACTFL nodes; it can be in the final position.  Otherwise
4067              * we can stop looking 1 byte earlier because have to find at least
4068              * two characters for a multi-fold */
4069             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4070                               ? s_end
4071                               : s_end -1;
4072
4073             while (s < upper) {
4074                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4075                 if (! len) {    /* Not a multi-char fold. */
4076                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4077                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4078                     {
4079                         *unfolded_multi_char = TRUE;
4080                     }
4081                     s++;
4082                     continue;
4083                 }
4084
4085                 if (len == 2
4086                     && isALPHA_FOLD_EQ(*s, 's')
4087                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4088                 {
4089
4090                     /* EXACTF nodes need to know that the minimum length
4091                      * changed so that a sharp s in the string can match this
4092                      * ss in the pattern, but they remain EXACTF nodes, as they
4093                      * won't match this unless the target string is is UTF-8,
4094                      * which we don't know until runtime.  EXACTFL nodes can't
4095                      * transform into EXACTFU nodes */
4096                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4097                         OP(scan) = EXACTFU_SS;
4098                     }
4099                 }
4100
4101                 *min_subtract += len - 1;
4102                 s += len;
4103             }
4104 #endif
4105         }
4106     }
4107
4108 #ifdef DEBUGGING
4109     /* Allow dumping but overwriting the collection of skipped
4110      * ops and/or strings with fake optimized ops */
4111     n = scan + NODE_SZ_STR(scan);
4112     while (n <= stop) {
4113         OP(n) = OPTIMIZED;
4114         FLAGS(n) = 0;
4115         NEXT_OFF(n) = 0;
4116         n++;
4117     }
4118 #endif
4119     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl", scan, depth, 0);});
4120     return stopnow;
4121 }
4122
4123 /* REx optimizer.  Converts nodes into quicker variants "in place".
4124    Finds fixed substrings.  */
4125
4126 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4127    to the position after last scanned or to NULL. */
4128
4129 #define INIT_AND_WITHP \
4130     assert(!and_withp); \
4131     Newx(and_withp,1, regnode_ssc); \
4132     SAVEFREEPV(and_withp)
4133
4134
4135 static void
4136 S_unwind_scan_frames(pTHX_ const void *p)
4137 {
4138     scan_frame *f= (scan_frame *)p;
4139     do {
4140         scan_frame *n= f->next_frame;
4141         Safefree(f);
4142         f= n;
4143     } while (f);
4144 }
4145
4146
4147 STATIC SSize_t
4148 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4149                         SSize_t *minlenp, SSize_t *deltap,
4150                         regnode *last,
4151                         scan_data_t *data,
4152                         I32 stopparen,
4153                         U32 recursed_depth,
4154                         regnode_ssc *and_withp,
4155                         U32 flags, U32 depth)
4156                         /* scanp: Start here (read-write). */
4157                         /* deltap: Write maxlen-minlen here. */
4158                         /* last: Stop before this one. */
4159                         /* data: string data about the pattern */
4160                         /* stopparen: treat close N as END */
4161                         /* recursed: which subroutines have we recursed into */
4162                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4163 {
4164     /* There must be at least this number of characters to match */
4165     SSize_t min = 0;
4166     I32 pars = 0, code;
4167     regnode *scan = *scanp, *next;
4168     SSize_t delta = 0;
4169     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4170     int is_inf_internal = 0;            /* The studied chunk is infinite */
4171     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4172     scan_data_t data_fake;
4173     SV *re_trie_maxbuff = NULL;
4174     regnode *first_non_open = scan;
4175     SSize_t stopmin = SSize_t_MAX;
4176     scan_frame *frame = NULL;
4177     GET_RE_DEBUG_FLAGS_DECL;
4178
4179     PERL_ARGS_ASSERT_STUDY_CHUNK;
4180     RExC_study_started= 1;
4181
4182
4183     if ( depth == 0 ) {
4184         while (first_non_open && OP(first_non_open) == OPEN)
4185             first_non_open=regnext(first_non_open);
4186     }
4187
4188
4189   fake_study_recurse:
4190     DEBUG_r(
4191         RExC_study_chunk_recursed_count++;
4192     );
4193     DEBUG_OPTIMISE_MORE_r(
4194     {
4195         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4196             depth, (long)stopparen,
4197             (unsigned long)RExC_study_chunk_recursed_count,
4198             (unsigned long)depth, (unsigned long)recursed_depth,
4199             scan,
4200             last);
4201         if (recursed_depth) {
4202             U32 i;
4203             U32 j;
4204             for ( j = 0 ; j < recursed_depth ; j++ ) {
4205                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4206                     if (
4207                         PAREN_TEST(RExC_study_chunk_recursed +
4208                                    ( j * RExC_study_chunk_recursed_bytes), i )
4209                         && (
4210                             !j ||
4211                             !PAREN_TEST(RExC_study_chunk_recursed +
4212                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4213                         )
4214                     ) {
4215                         Perl_re_printf( aTHX_ " %d",(int)i);
4216                         break;
4217                     }
4218                 }
4219                 if ( j + 1 < recursed_depth ) {
4220                     Perl_re_printf( aTHX_  ",");
4221                 }
4222             }
4223         }
4224         Perl_re_printf( aTHX_ "\n");
4225     }
4226     );
4227     while ( scan && OP(scan) != END && scan < last ){
4228         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4229                                    node length to get a real minimum (because
4230                                    the folded version may be shorter) */
4231         bool unfolded_multi_char = FALSE;
4232         /* Peephole optimizer: */
4233         DEBUG_STUDYDATA("Peep", data, depth, is_inf);
4234         DEBUG_PEEP("Peep", scan, depth, flags);
4235
4236
4237         /* The reason we do this here is that we need to deal with things like
4238          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4239          * parsing code, as each (?:..) is handled by a different invocation of
4240          * reg() -- Yves
4241          */
4242         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4243
4244         /* Follow the next-chain of the current node and optimize
4245            away all the NOTHINGs from it.  */
4246         if (OP(scan) != CURLYX) {
4247             const int max = (reg_off_by_arg[OP(scan)]
4248                        ? I32_MAX
4249                        /* I32 may be smaller than U16 on CRAYs! */
4250                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4251             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4252             int noff;
4253             regnode *n = scan;
4254
4255             /* Skip NOTHING and LONGJMP. */
4256             while ((n = regnext(n))
4257                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4258                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4259                    && off + noff < max)
4260                 off += noff;
4261             if (reg_off_by_arg[OP(scan)])
4262                 ARG(scan) = off;
4263             else
4264                 NEXT_OFF(scan) = off;
4265         }
4266
4267         /* The principal pseudo-switch.  Cannot be a switch, since we
4268            look into several different things.  */
4269         if ( OP(scan) == DEFINEP ) {
4270             SSize_t minlen = 0;
4271             SSize_t deltanext = 0;
4272             SSize_t fake_last_close = 0;
4273             I32 f = SCF_IN_DEFINE;
4274
4275             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4276             scan = regnext(scan);
4277             assert( OP(scan) == IFTHEN );
4278             DEBUG_PEEP("expect IFTHEN", scan, depth, flags);
4279
4280             data_fake.last_closep= &fake_last_close;
4281             minlen = *minlenp;
4282             next = regnext(scan);
4283             scan = NEXTOPER(NEXTOPER(scan));
4284             DEBUG_PEEP("scan", scan, depth, flags);
4285             DEBUG_PEEP("next", next, depth, flags);
4286
4287             /* we suppose the run is continuous, last=next...
4288              * NOTE we dont use the return here! */
4289             (void)study_chunk(pRExC_state, &scan, &minlen,
4290                               &deltanext, next, &data_fake, stopparen,
4291                               recursed_depth, NULL, f, depth+1);
4292
4293             scan = next;
4294         } else
4295         if (
4296             OP(scan) == BRANCH  ||
4297             OP(scan) == BRANCHJ ||
4298             OP(scan) == IFTHEN
4299         ) {
4300             next = regnext(scan);
4301             code = OP(scan);
4302
4303             /* The op(next)==code check below is to see if we
4304              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4305              * IFTHEN is special as it might not appear in pairs.
4306              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4307              * we dont handle it cleanly. */
4308             if (OP(next) == code || code == IFTHEN) {
4309                 /* NOTE - There is similar code to this block below for
4310                  * handling TRIE nodes on a re-study.  If you change stuff here
4311                  * check there too. */
4312                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4313                 regnode_ssc accum;
4314                 regnode * const startbranch=scan;
4315
4316                 if (flags & SCF_DO_SUBSTR) {
4317                     /* Cannot merge strings after this. */
4318                     scan_commit(pRExC_state, data, minlenp, is_inf);
4319                 }
4320
4321                 if (flags & SCF_DO_STCLASS)
4322                     ssc_init_zero(pRExC_state, &accum);
4323
4324                 while (OP(scan) == code) {
4325                     SSize_t deltanext, minnext, fake;
4326                     I32 f = 0;
4327                     regnode_ssc this_class;
4328
4329                     DEBUG_PEEP("Branch", scan, depth, flags);
4330
4331                     num++;
4332                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4333                     if (data) {
4334                         data_fake.whilem_c = data->whilem_c;
4335                         data_fake.last_closep = data->last_closep;
4336                     }
4337                     else
4338                         data_fake.last_closep = &fake;
4339
4340                     data_fake.pos_delta = delta;
4341                     next = regnext(scan);
4342
4343                     scan = NEXTOPER(scan); /* everything */
4344                     if (code != BRANCH)    /* everything but BRANCH */
4345                         scan = NEXTOPER(scan);
4346
4347                     if (flags & SCF_DO_STCLASS) {
4348                         ssc_init(pRExC_state, &this_class);
4349                         data_fake.start_class = &this_class;
4350                         f = SCF_DO_STCLASS_AND;
4351                     }
4352                     if (flags & SCF_WHILEM_VISITED_POS)
4353                         f |= SCF_WHILEM_VISITED_POS;
4354
4355                     /* we suppose the run is continuous, last=next...*/
4356                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4357                                       &deltanext, next, &data_fake, stopparen,
4358                                       recursed_depth, NULL, f,depth+1);
4359
4360                     if (min1 > minnext)
4361                         min1 = minnext;
4362                     if (deltanext == SSize_t_MAX) {
4363                         is_inf = is_inf_internal = 1;
4364                         max1 = SSize_t_MAX;
4365                     } else if (max1 < minnext + deltanext)
4366                         max1 = minnext + deltanext;
4367                     scan = next;
4368                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4369                         pars++;
4370                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4371                         if ( stopmin > minnext)
4372                             stopmin = min + min1;
4373                         flags &= ~SCF_DO_SUBSTR;
4374                         if (data)
4375                             data->flags |= SCF_SEEN_ACCEPT;
4376                     }
4377                     if (data) {
4378                         if (data_fake.flags & SF_HAS_EVAL)
4379                             data->flags |= SF_HAS_EVAL;
4380                         data->whilem_c = data_fake.whilem_c;
4381                     }
4382                     if (flags & SCF_DO_STCLASS)
4383                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4384                 }
4385                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4386                     min1 = 0;
4387                 if (flags & SCF_DO_SUBSTR) {
4388                     data->pos_min += min1;
4389                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4390                         data->pos_delta = SSize_t_MAX;
4391                     else
4392                         data->pos_delta += max1 - min1;
4393                     if (max1 != min1 || is_inf)
4394                         data->cur_is_floating = 1;
4395                 }
4396                 min += min1;
4397                 if (delta == SSize_t_MAX
4398                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4399                     delta = SSize_t_MAX;
4400                 else
4401                     delta += max1 - min1;
4402                 if (flags & SCF_DO_STCLASS_OR) {
4403                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4404                     if (min1) {
4405                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4406                         flags &= ~SCF_DO_STCLASS;
4407                     }
4408                 }
4409                 else if (flags & SCF_DO_STCLASS_AND) {
4410                     if (min1) {
4411                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4412                         flags &= ~SCF_DO_STCLASS;
4413                     }
4414                     else {
4415                         /* Switch to OR mode: cache the old value of
4416                          * data->start_class */
4417                         INIT_AND_WITHP;
4418                         StructCopy(data->start_class, and_withp, regnode_ssc);
4419                         flags &= ~SCF_DO_STCLASS_AND;
4420                         StructCopy(&accum, data->start_class, regnode_ssc);
4421                         flags |= SCF_DO_STCLASS_OR;
4422                     }
4423                 }
4424
4425                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4426                         OP( startbranch ) == BRANCH )
4427                 {
4428                 /* demq.
4429
4430                    Assuming this was/is a branch we are dealing with: 'scan'
4431                    now points at the item that follows the branch sequence,
4432                    whatever it is. We now start at the beginning of the
4433                    sequence and look for subsequences of
4434
4435                    BRANCH->EXACT=>x1
4436                    BRANCH->EXACT=>x2
4437                    tail
4438
4439                    which would be constructed from a pattern like
4440                    /A|LIST|OF|WORDS/
4441
4442                    If we can find such a subsequence we need to turn the first
4443                    element into a trie and then add the subsequent branch exact
4444                    strings to the trie.
4445
4446                    We have two cases
4447
4448                      1. patterns where the whole set of branches can be
4449                         converted.
4450
4451                      2. patterns where only a subset can be converted.
4452
4453                    In case 1 we can replace the whole set with a single regop
4454                    for the trie. In case 2 we need to keep the start and end
4455                    branches so
4456
4457                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4458                      becomes BRANCH TRIE; BRANCH X;
4459
4460                   There is an additional case, that being where there is a
4461                   common prefix, which gets split out into an EXACT like node
4462                   preceding the TRIE node.
4463
4464                   If x(1..n)==tail then we can do a simple trie, if not we make
4465                   a "jump" trie, such that when we match the appropriate word
4466                   we "jump" to the appropriate tail node. Essentially we turn
4467                   a nested if into a case structure of sorts.
4468
4469                 */
4470
4471                     int made=0;
4472                     if (!re_trie_maxbuff) {
4473                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4474                         if (!SvIOK(re_trie_maxbuff))
4475                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4476                     }
4477                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4478                         regnode *cur;
4479                         regnode *first = (regnode *)NULL;
4480                         regnode *last = (regnode *)NULL;
4481                         regnode *tail = scan;
4482                         U8 trietype = 0;
4483                         U32 count=0;
4484
4485                         /* var tail is used because there may be a TAIL
4486                            regop in the way. Ie, the exacts will point to the
4487                            thing following the TAIL, but the last branch will
4488                            point at the TAIL. So we advance tail. If we
4489                            have nested (?:) we may have to move through several
4490                            tails.
4491                          */
4492
4493                         while ( OP( tail ) == TAIL ) {
4494                             /* this is the TAIL generated by (?:) */
4495                             tail = regnext( tail );
4496                         }
4497
4498
4499                         DEBUG_TRIE_COMPILE_r({
4500                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4501                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4502                               depth+1,
4503                               "Looking for TRIE'able sequences. Tail node is ",
4504                               (UV)(tail - RExC_emit_start),
4505                               SvPV_nolen_const( RExC_mysv )
4506                             );
4507                         });
4508
4509                         /*
4510
4511                             Step through the branches
4512                                 cur represents each branch,
4513                                 noper is the first thing to be matched as part
4514                                       of that branch
4515                                 noper_next is the regnext() of that node.
4516
4517                             We normally handle a case like this
4518                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4519                             support building with NOJUMPTRIE, which restricts
4520                             the trie logic to structures like /FOO|BAR/.
4521
4522                             If noper is a trieable nodetype then the branch is
4523                             a possible optimization target. If we are building
4524                             under NOJUMPTRIE then we require that noper_next is
4525                             the same as scan (our current position in the regex
4526                             program).
4527
4528                             Once we have two or more consecutive such branches
4529                             we can create a trie of the EXACT's contents and
4530                             stitch it in place into the program.
4531
4532                             If the sequence represents all of the branches in
4533                             the alternation we replace the entire thing with a
4534                             single TRIE node.
4535
4536                             Otherwise when it is a subsequence we need to
4537                             stitch it in place and replace only the relevant
4538                             branches. This means the first branch has to remain
4539                             as it is used by the alternation logic, and its
4540                             next pointer, and needs to be repointed at the item
4541                             on the branch chain following the last branch we
4542                             have optimized away.
4543
4544                             This could be either a BRANCH, in which case the
4545                             subsequence is internal, or it could be the item
4546                             following the branch sequence in which case the
4547                             subsequence is at the end (which does not
4548                             necessarily mean the first node is the start of the
4549                             alternation).
4550
4551                             TRIE_TYPE(X) is a define which maps the optype to a
4552                             trietype.
4553
4554                                 optype          |  trietype
4555                                 ----------------+-----------
4556                                 NOTHING         | NOTHING
4557                                 EXACT           | EXACT
4558                                 EXACTFU         | EXACTFU
4559                                 EXACTFU_SS      | EXACTFU
4560                                 EXACTFA         | EXACTFA
4561                                 EXACTL          | EXACTL
4562                                 EXACTFLU8       | EXACTFLU8
4563
4564
4565                         */
4566 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4567                        ? NOTHING                                            \
4568                        : ( EXACT == (X) )                                   \
4569                          ? EXACT                                            \
4570                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4571                            ? EXACTFU                                        \
4572                            : ( EXACTFA == (X) )                             \
4573                              ? EXACTFA                                      \
4574                              : ( EXACTL == (X) )                            \
4575                                ? EXACTL                                     \
4576                                : ( EXACTFLU8 == (X) )                        \
4577                                  ? EXACTFLU8                                 \
4578                                  : 0 )
4579
4580                         /* dont use tail as the end marker for this traverse */
4581                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4582                             regnode * const noper = NEXTOPER( cur );
4583                             U8 noper_type = OP( noper );
4584                             U8 noper_trietype = TRIE_TYPE( noper_type );
4585 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4586                             regnode * const noper_next = regnext( noper );
4587                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4588                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4589 #endif
4590
4591                             DEBUG_TRIE_COMPILE_r({
4592                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4593                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4594                                    depth+1,
4595                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4596
4597                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4598                                 Perl_re_printf( aTHX_  " -> %d:%s",
4599                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4600
4601                                 if ( noper_next ) {
4602                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4603                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4604                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4605                                 }
4606                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4607                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4608                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4609                                 );
4610                             });
4611
4612                             /* Is noper a trieable nodetype that can be merged
4613                              * with the current trie (if there is one)? */
4614                             if ( noper_trietype
4615                                   &&
4616                                   (
4617                                         ( noper_trietype == NOTHING )
4618                                         || ( trietype == NOTHING )
4619                                         || ( trietype == noper_trietype )
4620                                   )
4621 #ifdef NOJUMPTRIE
4622                                   && noper_next >= tail
4623 #endif
4624                                   && count < U16_MAX)
4625                             {
4626                                 /* Handle mergable triable node Either we are
4627                                  * the first node in a new trieable sequence,
4628                                  * in which case we do some bookkeeping,
4629                                  * otherwise we update the end pointer. */
4630                                 if ( !first ) {
4631                                     first = cur;
4632                                     if ( noper_trietype == NOTHING ) {
4633 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4634                                         regnode * const noper_next = regnext( noper );
4635                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4636                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4637 #endif
4638
4639                                         if ( noper_next_trietype ) {
4640                                             trietype = noper_next_trietype;
4641                                         } else if (noper_next_type)  {
4642                                             /* a NOTHING regop is 1 regop wide.
4643                                              * We need at least two for a trie
4644                                              * so we can't merge this in */
4645                                             first = NULL;
4646                                         }
4647                                     } else {
4648                                         trietype = noper_trietype;
4649                                     }
4650                                 } else {
4651                                     if ( trietype == NOTHING )
4652                                         trietype = noper_trietype;
4653                                     last = cur;
4654                                 }
4655                                 if (first)
4656                                     count++;
4657                             } /* end handle mergable triable node */
4658                             else {
4659                                 /* handle unmergable node -
4660                                  * noper may either be a triable node which can
4661                                  * not be tried together with the current trie,
4662                                  * or a non triable node */
4663                                 if ( last ) {
4664                                     /* If last is set and trietype is not
4665                                      * NOTHING then we have found at least two
4666                                      * triable branch sequences in a row of a
4667                                      * similar trietype so we can turn them
4668                                      * into a trie. If/when we allow NOTHING to
4669                                      * start a trie sequence this condition
4670                                      * will be required, and it isn't expensive
4671                                      * so we leave it in for now. */
4672                                     if ( trietype && trietype != NOTHING )
4673                                         make_trie( pRExC_state,
4674                                                 startbranch, first, cur, tail,
4675                                                 count, trietype, depth+1 );
4676                                     last = NULL; /* note: we clear/update
4677                                                     first, trietype etc below,
4678                                                     so we dont do it here */
4679                                 }
4680                                 if ( noper_trietype
4681 #ifdef NOJUMPTRIE
4682                                      && noper_next >= tail
4683 #endif
4684                                 ){
4685                                     /* noper is triable, so we can start a new
4686                                      * trie sequence */
4687                                     count = 1;
4688                                     first = cur;
4689                                     trietype = noper_trietype;
4690                                 } else if (first) {
4691                                     /* if we already saw a first but the
4692                                      * current node is not triable then we have
4693                                      * to reset the first information. */
4694                                     count = 0;
4695                                     first = NULL;
4696                                     trietype = 0;
4697                                 }
4698                             } /* end handle unmergable node */
4699                         } /* loop over branches */
4700                         DEBUG_TRIE_COMPILE_r({
4701                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4702                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4703                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4704                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4705                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4706                                PL_reg_name[trietype]
4707                             );
4708
4709                         });
4710                         if ( last && trietype ) {
4711                             if ( trietype != NOTHING ) {
4712                                 /* the last branch of the sequence was part of
4713                                  * a trie, so we have to construct it here
4714                                  * outside of the loop */
4715                                 made= make_trie( pRExC_state, startbranch,
4716                                                  first, scan, tail, count,
4717                                                  trietype, depth+1 );
4718 #ifdef TRIE_STUDY_OPT
4719                                 if ( ((made == MADE_EXACT_TRIE &&
4720                                      startbranch == first)
4721                                      || ( first_non_open == first )) &&
4722                                      depth==0 ) {
4723                                     flags |= SCF_TRIE_RESTUDY;
4724                                     if ( startbranch == first
4725                                          && scan >= tail )
4726                                     {
4727                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4728                                     }
4729                                 }
4730 #endif
4731                             } else {
4732                                 /* at this point we know whatever we have is a
4733                                  * NOTHING sequence/branch AND if 'startbranch'
4734                                  * is 'first' then we can turn the whole thing
4735                                  * into a NOTHING
4736                                  */
4737                                 if ( startbranch == first ) {
4738                                     regnode *opt;
4739                                     /* the entire thing is a NOTHING sequence,
4740                                      * something like this: (?:|) So we can
4741                                      * turn it into a plain NOTHING op. */
4742                                     DEBUG_TRIE_COMPILE_r({
4743                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4744                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4745                                           depth+1,
4746                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4747
4748                                     });
4749                                     OP(startbranch)= NOTHING;
4750                                     NEXT_OFF(startbranch)= tail - startbranch;
4751                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4752                                         OP(opt)= OPTIMIZED;
4753                                 }
4754                             }
4755                         } /* end if ( last) */
4756                     } /* TRIE_MAXBUF is non zero */
4757
4758                 } /* do trie */
4759
4760             }
4761             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4762                 scan = NEXTOPER(NEXTOPER(scan));
4763             } else                      /* single branch is optimized. */
4764                 scan = NEXTOPER(scan);
4765             continue;
4766         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4767             I32 paren = 0;
4768             regnode *start = NULL;
4769             regnode *end = NULL;
4770             U32 my_recursed_depth= recursed_depth;
4771
4772             if (OP(scan) != SUSPEND) { /* GOSUB */
4773                 /* Do setup, note this code has side effects beyond
4774                  * the rest of this block. Specifically setting
4775                  * RExC_recurse[] must happen at least once during
4776                  * study_chunk(). */
4777                 paren = ARG(scan);
4778                 RExC_recurse[ARG2L(scan)] = scan;
4779                 start = RExC_open_parens[paren];
4780                 end   = RExC_close_parens[paren];
4781
4782                 /* NOTE we MUST always execute the above code, even
4783                  * if we do nothing with a GOSUB */
4784                 if (
4785                     ( flags & SCF_IN_DEFINE )
4786                     ||
4787                     (
4788                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4789                         &&
4790                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4791                     )
4792                 ) {
4793                     /* no need to do anything here if we are in a define. */
4794                     /* or we are after some kind of infinite construct
4795                      * so we can skip recursing into this item.
4796                      * Since it is infinite we will not change the maxlen
4797                      * or delta, and if we miss something that might raise
4798                      * the minlen it will merely pessimise a little.
4799                      *
4800                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4801                      * might result in a minlen of 1 and not of 4,
4802                      * but this doesn't make us mismatch, just try a bit
4803                      * harder than we should.
4804                      * */
4805                     scan= regnext(scan);
4806                     continue;
4807                 }
4808
4809                 if (
4810                     !recursed_depth
4811                     ||
4812                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4813                 ) {
4814                     /* it is quite possible that there are more efficient ways
4815                      * to do this. We maintain a bitmap per level of recursion
4816                      * of which patterns we have entered so we can detect if a
4817                      * pattern creates a possible infinite loop. When we
4818                      * recurse down a level we copy the previous levels bitmap
4819                      * down. When we are at recursion level 0 we zero the top
4820                      * level bitmap. It would be nice to implement a different
4821                      * more efficient way of doing this. In particular the top
4822                      * level bitmap may be unnecessary.
4823                      */
4824                     if (!recursed_depth) {
4825                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4826                     } else {
4827                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4828                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4829                              RExC_study_chunk_recursed_bytes, U8);
4830                     }
4831                     /* we havent recursed into this paren yet, so recurse into it */
4832                     DEBUG_STUDYDATA("gosub-set", data, depth, is_inf);
4833                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4834                     my_recursed_depth= recursed_depth + 1;
4835                 } else {
4836                     DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf);
4837                     /* some form of infinite recursion, assume infinite length
4838                      * */
4839                     if (flags & SCF_DO_SUBSTR) {
4840                         scan_commit(pRExC_state, data, minlenp, is_inf);
4841                         data->cur_is_floating = 1;
4842                     }
4843                     is_inf = is_inf_internal = 1;
4844                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4845                         ssc_anything(data->start_class);
4846                     flags &= ~SCF_DO_STCLASS;
4847
4848                     start= NULL; /* reset start so we dont recurse later on. */
4849                 }
4850             } else {
4851                 paren = stopparen;
4852                 start = scan + 2;
4853                 end = regnext(scan);
4854             }
4855             if (start) {
4856                 scan_frame *newframe;
4857                 assert(end);
4858                 if (!RExC_frame_last) {
4859                     Newxz(newframe, 1, scan_frame);
4860                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4861                     RExC_frame_head= newframe;
4862                     RExC_frame_count++;
4863                 } else if (!RExC_frame_last->next_frame) {
4864                     Newxz(newframe,1,scan_frame);
4865                     RExC_frame_last->next_frame= newframe;
4866                     newframe->prev_frame= RExC_frame_last;
4867                     RExC_frame_count++;
4868                 } else {
4869                     newframe= RExC_frame_last->next_frame;
4870                 }
4871                 RExC_frame_last= newframe;
4872
4873                 newframe->next_regnode = regnext(scan);
4874                 newframe->last_regnode = last;
4875                 newframe->stopparen = stopparen;
4876                 newframe->prev_recursed_depth = recursed_depth;
4877                 newframe->this_prev_frame= frame;
4878
4879                 DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
4880                 DEBUG_PEEP("fnew", scan, depth, flags);
4881
4882                 frame = newframe;
4883                 scan =  start;
4884                 stopparen = paren;
4885                 last = end;
4886                 depth = depth + 1;
4887                 recursed_depth= my_recursed_depth;
4888
4889                 continue;
4890             }
4891         }
4892         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4893             SSize_t l = STR_LEN(scan);
4894             UV uc;
4895             if (UTF) {
4896                 const U8 * const s = (U8*)STRING(scan);
4897                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4898                 l = utf8_length(s, s + l);
4899             } else {
4900                 uc = *((U8*)STRING(scan));
4901             }
4902             min += l;
4903             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4904                 /* The code below prefers earlier match for fixed
4905                    offset, later match for variable offset.  */
4906                 if (data->last_end == -1) { /* Update the start info. */
4907                     data->last_start_min = data->pos_min;
4908                     data->last_start_max = is_inf
4909                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4910                 }
4911                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4912                 if (UTF)
4913                     SvUTF8_on(data->last_found);
4914                 {
4915                     SV * const sv = data->last_found;
4916                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4917                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4918                     if (mg && mg->mg_len >= 0)
4919                         mg->mg_len += utf8_length((U8*)STRING(scan),
4920                                               (U8*)STRING(scan)+STR_LEN(scan));
4921                 }
4922                 data->last_end = data->pos_min + l;
4923                 data->pos_min += l; /* As in the first entry. */
4924                 data->flags &= ~SF_BEFORE_EOL;
4925             }
4926
4927             /* ANDing the code point leaves at most it, and not in locale, and
4928              * can't match null string */
4929             if (flags & SCF_DO_STCLASS_AND) {
4930                 ssc_cp_and(data->start_class, uc);
4931                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4932                 ssc_clear_locale(data->start_class);
4933             }
4934             else if (flags & SCF_DO_STCLASS_OR) {
4935                 ssc_add_cp(data->start_class, uc);
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         }
4943         else if (PL_regkind[OP(scan)] == EXACT) {
4944             /* But OP != EXACT!, so is EXACTFish */
4945             SSize_t l = STR_LEN(scan);
4946             const U8 * s = (U8*)STRING(scan);
4947
4948             /* Search for fixed substrings supports EXACT only. */
4949             if (flags & SCF_DO_SUBSTR) {
4950                 assert(data);
4951                 scan_commit(pRExC_state, data, minlenp, is_inf);
4952             }
4953             if (UTF) {
4954                 l = utf8_length(s, s + l);
4955             }
4956             if (unfolded_multi_char) {
4957                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4958             }
4959             min += l - min_subtract;
4960             assert (min >= 0);
4961             delta += min_subtract;
4962             if (flags & SCF_DO_SUBSTR) {
4963                 data->pos_min += l - min_subtract;
4964                 if (data->pos_min < 0) {
4965                     data->pos_min = 0;
4966                 }
4967                 data->pos_delta += min_subtract;
4968                 if (min_subtract) {
4969                     data->cur_is_floating = 1; /* float */
4970                 }
4971             }
4972
4973             if (flags & SCF_DO_STCLASS) {
4974                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4975
4976                 assert(EXACTF_invlist);
4977                 if (flags & SCF_DO_STCLASS_AND) {
4978                     if (OP(scan) != EXACTFL)
4979                         ssc_clear_locale(data->start_class);
4980                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4981                     ANYOF_POSIXL_ZERO(data->start_class);
4982                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4983                 }
4984                 else {  /* SCF_DO_STCLASS_OR */
4985                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4986                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4987
4988                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4989                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4990                 }
4991                 flags &= ~SCF_DO_STCLASS;
4992                 SvREFCNT_dec(EXACTF_invlist);
4993             }
4994         }
4995         else if (REGNODE_VARIES(OP(scan))) {
4996             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4997             I32 fl = 0, f = flags;
4998             regnode * const oscan = scan;
4999             regnode_ssc this_class;
5000             regnode_ssc *oclass = NULL;
5001             I32 next_is_eval = 0;
5002
5003             switch (PL_regkind[OP(scan)]) {
5004             case WHILEM:                /* End of (?:...)* . */
5005                 scan = NEXTOPER(scan);
5006                 goto finish;
5007             case PLUS:
5008                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
5009                     next = NEXTOPER(scan);
5010                     if (OP(next) == EXACT
5011                         || OP(next) == EXACTL
5012                         || (flags & SCF_DO_STCLASS))
5013                     {
5014                         mincount = 1;
5015                         maxcount = REG_INFTY;
5016                         next = regnext(scan);
5017                         scan = NEXTOPER(scan);
5018                         goto do_curly;
5019                     }
5020                 }
5021                 if (flags & SCF_DO_SUBSTR)
5022                     data->pos_min++;
5023                 min++;
5024                 /* FALLTHROUGH */
5025             case STAR:
5026                 if (flags & SCF_DO_STCLASS) {
5027                     mincount = 0;
5028                     maxcount = REG_INFTY;
5029                     next = regnext(scan);
5030                     scan = NEXTOPER(scan);
5031                     goto do_curly;
5032                 }
5033                 if (flags & SCF_DO_SUBSTR) {
5034                     scan_commit(pRExC_state, data, minlenp, is_inf);
5035                     /* Cannot extend fixed substrings */
5036                     data->cur_is_floating = 1; /* float */
5037                 }
5038                 is_inf = is_inf_internal = 1;
5039                 scan = regnext(scan);
5040                 goto optimize_curly_tail;
5041             case CURLY:
5042                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
5043                     && (scan->flags == stopparen))
5044                 {
5045                     mincount = 1;
5046                     maxcount = 1;
5047                 } else {
5048                     mincount = ARG1(scan);
5049                     maxcount = ARG2(scan);
5050                 }
5051                 next = regnext(scan);
5052                 if (OP(scan) == CURLYX) {
5053                     I32 lp = (data ? *(data->last_closep) : 0);
5054                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5055                 }
5056                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5057                 next_is_eval = (OP(scan) == EVAL);
5058               do_curly:
5059                 if (flags & SCF_DO_SUBSTR) {
5060                     if (mincount == 0)
5061                         scan_commit(pRExC_state, data, minlenp, is_inf);
5062                     /* Cannot extend fixed substrings */
5063                     pos_before = data->pos_min;
5064                 }
5065                 if (data) {
5066                     fl = data->flags;
5067                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5068                     if (is_inf)
5069                         data->flags |= SF_IS_INF;
5070                 }
5071                 if (flags & SCF_DO_STCLASS) {
5072                     ssc_init(pRExC_state, &this_class);
5073                     oclass = data->start_class;
5074                     data->start_class = &this_class;
5075                     f |= SCF_DO_STCLASS_AND;
5076                     f &= ~SCF_DO_STCLASS_OR;
5077                 }
5078                 /* Exclude from super-linear cache processing any {n,m}
5079                    regops for which the combination of input pos and regex
5080                    pos is not enough information to determine if a match
5081                    will be possible.
5082
5083                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5084                    regex pos at the \s*, the prospects for a match depend not
5085                    only on the input position but also on how many (bar\s*)
5086                    repeats into the {4,8} we are. */
5087                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5088                     f &= ~SCF_WHILEM_VISITED_POS;
5089
5090                 /* This will finish on WHILEM, setting scan, or on NULL: */
5091                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5092                                   last, data, stopparen, recursed_depth, NULL,
5093                                   (mincount == 0
5094                                    ? (f & ~SCF_DO_SUBSTR)
5095                                    : f)
5096                                   ,depth+1);
5097
5098                 if (flags & SCF_DO_STCLASS)
5099                     data->start_class = oclass;
5100                 if (mincount == 0 || minnext == 0) {
5101                     if (flags & SCF_DO_STCLASS_OR) {
5102                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5103                     }
5104                     else if (flags & SCF_DO_STCLASS_AND) {
5105                         /* Switch to OR mode: cache the old value of
5106                          * data->start_class */
5107                         INIT_AND_WITHP;
5108                         StructCopy(data->start_class, and_withp, regnode_ssc);
5109                         flags &= ~SCF_DO_STCLASS_AND;
5110                         StructCopy(&this_class, data->start_class, regnode_ssc);
5111                         flags |= SCF_DO_STCLASS_OR;
5112                         ANYOF_FLAGS(data->start_class)
5113                                                 |= SSC_MATCHES_EMPTY_STRING;
5114                     }
5115                 } else {                /* Non-zero len */
5116                     if (flags & SCF_DO_STCLASS_OR) {
5117                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5118                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5119                     }
5120                     else if (flags & SCF_DO_STCLASS_AND)
5121                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5122                     flags &= ~SCF_DO_STCLASS;
5123                 }
5124                 if (!scan)              /* It was not CURLYX, but CURLY. */
5125                     scan = next;
5126                 if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR)
5127                     /* ? quantifier ok, except for (?{ ... }) */
5128                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5129                     && (minnext == 0) && (deltanext == 0)
5130                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5131                     && maxcount <= REG_INFTY/3) /* Complement check for big
5132                                                    count */
5133                 {
5134                     /* Fatal warnings may leak the regexp without this: */
5135                     SAVEFREESV(RExC_rx_sv);
5136                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5137                         "Quantifier unexpected on zero-length expression "
5138                         "in regex m/%" UTF8f "/",
5139                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5140                                   RExC_precomp));
5141                     (void)ReREFCNT_inc(RExC_rx_sv);
5142                 }
5143
5144                 min += minnext * mincount;
5145                 is_inf_internal |= deltanext == SSize_t_MAX
5146                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5147                 is_inf |= is_inf_internal;
5148                 if (is_inf) {
5149                     delta = SSize_t_MAX;
5150                 } else {
5151                     delta += (minnext + deltanext) * maxcount
5152                              - minnext * mincount;
5153                 }
5154                 /* Try powerful optimization CURLYX => CURLYN. */
5155                 if (  OP(oscan) == CURLYX && data
5156                       && data->flags & SF_IN_PAR
5157                       && !(data->flags & SF_HAS_EVAL)
5158                       && !deltanext && minnext == 1 ) {
5159                     /* Try to optimize to CURLYN.  */
5160                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5161                     regnode * const nxt1 = nxt;
5162 #ifdef DEBUGGING
5163                     regnode *nxt2;
5164 #endif
5165
5166                     /* Skip open. */
5167                     nxt = regnext(nxt);
5168                     if (!REGNODE_SIMPLE(OP(nxt))
5169                         && !(PL_regkind[OP(nxt)] == EXACT
5170                              && STR_LEN(nxt) == 1))
5171                         goto nogo;
5172 #ifdef DEBUGGING
5173                     nxt2 = nxt;
5174 #endif
5175                     nxt = regnext(nxt);
5176                     if (OP(nxt) != CLOSE)
5177                         goto nogo;
5178                     if (RExC_open_parens) {
5179                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5180                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5181                     }
5182                     /* Now we know that nxt2 is the only contents: */
5183                     oscan->flags = (U8)ARG(nxt);
5184                     OP(oscan) = CURLYN;
5185                     OP(nxt1) = NOTHING; /* was OPEN. */
5186
5187 #ifdef DEBUGGING
5188                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5189                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5190                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5191                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5192                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5193                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5194 #endif
5195                 }
5196               nogo:
5197
5198                 /* Try optimization CURLYX => CURLYM. */
5199                 if (  OP(oscan) == CURLYX && data
5200                       && !(data->flags & SF_HAS_PAR)
5201                       && !(data->flags & SF_HAS_EVAL)
5202                       && !deltanext     /* atom is fixed width */
5203                       && minnext != 0   /* CURLYM can't handle zero width */
5204
5205                          /* Nor characters whose fold at run-time may be
5206                           * multi-character */
5207                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5208                 ) {
5209                     /* XXXX How to optimize if data == 0? */
5210                     /* Optimize to a simpler form.  */
5211                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5212                     regnode *nxt2;
5213
5214                     OP(oscan) = CURLYM;
5215                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5216                             && (OP(nxt2) != WHILEM))
5217                         nxt = nxt2;
5218                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5219                     /* Need to optimize away parenths. */
5220                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5221                         /* Set the parenth number.  */
5222                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5223
5224                         oscan->flags = (U8)ARG(nxt);
5225                         if (RExC_open_parens) {
5226                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5227                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5228                         }
5229                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5230                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5231
5232 #ifdef DEBUGGING
5233                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5234                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5235                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5236                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5237 #endif
5238 #if 0
5239                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5240                             regnode *nnxt = regnext(nxt1);
5241                             if (nnxt == nxt) {
5242                                 if (reg_off_by_arg[OP(nxt1)])
5243                                     ARG_SET(nxt1, nxt2 - nxt1);
5244                                 else if (nxt2 - nxt1 < U16_MAX)
5245                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5246                                 else
5247                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5248                             }
5249                             nxt1 = nnxt;
5250                         }
5251 #endif
5252                         /* Optimize again: */
5253                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5254                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5255                     }
5256                     else
5257                         oscan->flags = 0;
5258                 }
5259                 else if ((OP(oscan) == CURLYX)
5260                          && (flags & SCF_WHILEM_VISITED_POS)
5261                          /* See the comment on a similar expression above.
5262                             However, this time it's not a subexpression
5263                             we care about, but the expression itself. */
5264                          && (maxcount == REG_INFTY)
5265                          && data) {
5266                     /* This stays as CURLYX, we can put the count/of pair. */
5267                     /* Find WHILEM (as in regexec.c) */
5268                     regnode *nxt = oscan + NEXT_OFF(oscan);
5269
5270                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5271                         nxt += ARG(nxt);
5272                     nxt = PREVOPER(nxt);
5273                     if (nxt->flags & 0xf) {
5274                         /* we've already set whilem count on this node */
5275                     } else if (++data->whilem_c < 16) {
5276                         assert(data->whilem_c <= RExC_whilem_seen);
5277                         nxt->flags = (U8)(data->whilem_c
5278                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5279                     }
5280                 }
5281                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5282                     pars++;
5283                 if (flags & SCF_DO_SUBSTR) {
5284                     SV *last_str = NULL;
5285                     STRLEN last_chrs = 0;
5286                     int counted = mincount != 0;
5287
5288                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5289                                                                   string. */
5290                         SSize_t b = pos_before >= data->last_start_min
5291                             ? pos_before : data->last_start_min;
5292                         STRLEN l;
5293                         const char * const s = SvPV_const(data->last_found, l);
5294                         SSize_t old = b - data->last_start_min;
5295
5296                         if (UTF)
5297                             old = utf8_hop((U8*)s, old) - (U8*)s;
5298                         l -= old;
5299                         /* Get the added string: */
5300                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5301                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5302                                             (U8*)(s + old + l)) : l;
5303                         if (deltanext == 0 && pos_before == b) {
5304                             /* What was added is a constant string */
5305                             if (mincount > 1) {
5306
5307                                 SvGROW(last_str, (mincount * l) + 1);
5308                                 repeatcpy(SvPVX(last_str) + l,
5309                                           SvPVX_const(last_str), l,
5310                                           mincount - 1);
5311                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5312                                 /* Add additional parts. */
5313                                 SvCUR_set(data->last_found,
5314                                           SvCUR(data->last_found) - l);
5315                                 sv_catsv(data->last_found, last_str);
5316                                 {
5317                                     SV * sv = data->last_found;
5318                                     MAGIC *mg =
5319                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5320                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5321                                     if (mg && mg->mg_len >= 0)
5322                                         mg->mg_len += last_chrs * (mincount-1);
5323                                 }
5324                                 last_chrs *= mincount;
5325                                 data->last_end += l * (mincount - 1);
5326                             }
5327                         } else {
5328                             /* start offset must point into the last copy */
5329                             data->last_start_min += minnext * (mincount - 1);
5330                             data->last_start_max =
5331                               is_inf
5332                                ? SSize_t_MAX
5333                                : data->last_start_max +
5334                                  (maxcount - 1) * (minnext + data->pos_delta);
5335                         }
5336                     }
5337                     /* It is counted once already... */
5338                     data->pos_min += minnext * (mincount - counted);
5339 #if 0
5340 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5341                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5342                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5343     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5344     (UV)mincount);
5345 if (deltanext != SSize_t_MAX)
5346 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5347     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5348           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5349 #endif
5350                     if (deltanext == SSize_t_MAX
5351                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5352                         data->pos_delta = SSize_t_MAX;
5353                     else
5354                         data->pos_delta += - counted * deltanext +
5355                         (minnext + deltanext) * maxcount - minnext * mincount;
5356                     if (mincount != maxcount) {
5357                          /* Cannot extend fixed substrings found inside
5358                             the group.  */
5359                         scan_commit(pRExC_state, data, minlenp, is_inf);
5360                         if (mincount && last_str) {
5361                             SV * const sv = data->last_found;
5362                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5363                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5364
5365                             if (mg)
5366                                 mg->mg_len = -1;
5367                             sv_setsv(sv, last_str);
5368                             data->last_end = data->pos_min;
5369                             data->last_start_min = data->pos_min - last_chrs;
5370                             data->last_start_max = is_inf
5371                                 ? SSize_t_MAX
5372                                 : data->pos_min + data->pos_delta - last_chrs;
5373                         }
5374                         data->cur_is_floating = 1; /* float */
5375                     }
5376                     SvREFCNT_dec(last_str);
5377                 }
5378                 if (data && (fl & SF_HAS_EVAL))
5379                     data->flags |= SF_HAS_EVAL;
5380               optimize_curly_tail:
5381                 if (OP(oscan) != CURLYX) {
5382                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5383                            && NEXT_OFF(next))
5384                         NEXT_OFF(oscan) += NEXT_OFF(next);
5385                 }
5386                 continue;
5387
5388             default:
5389 #ifdef DEBUGGING
5390                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5391                                                                     OP(scan));
5392 #endif
5393             case REF:
5394             case CLUMP:
5395                 if (flags & SCF_DO_SUBSTR) {
5396                     /* Cannot expect anything... */
5397                     scan_commit(pRExC_state, data, minlenp, is_inf);
5398                     data->cur_is_floating = 1; /* float */
5399                 }
5400                 is_inf = is_inf_internal = 1;
5401                 if (flags & SCF_DO_STCLASS_OR) {
5402                     if (OP(scan) == CLUMP) {
5403                         /* Actually is any start char, but very few code points
5404                          * aren't start characters */
5405                         ssc_match_all_cp(data->start_class);
5406                     }
5407                     else {
5408                         ssc_anything(data->start_class);
5409                     }
5410                 }
5411                 flags &= ~SCF_DO_STCLASS;
5412                 break;
5413             }
5414         }
5415         else if (OP(scan) == LNBREAK) {
5416             if (flags & SCF_DO_STCLASS) {
5417                 if (flags & SCF_DO_STCLASS_AND) {
5418                     ssc_intersection(data->start_class,
5419                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5420                     ssc_clear_locale(data->start_class);
5421                     ANYOF_FLAGS(data->start_class)
5422                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5423                 }
5424                 else if (flags & SCF_DO_STCLASS_OR) {
5425                     ssc_union(data->start_class,
5426                               PL_XPosix_ptrs[_CC_VERTSPACE],
5427                               FALSE);
5428                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5429
5430                     /* See commit msg for
5431                      * 749e076fceedeb708a624933726e7989f2302f6a */
5432                     ANYOF_FLAGS(data->start_class)
5433                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5434                 }
5435                 flags &= ~SCF_DO_STCLASS;
5436             }
5437             min++;
5438             if (delta != SSize_t_MAX)
5439                 delta++;    /* Because of the 2 char string cr-lf */
5440             if (flags & SCF_DO_SUBSTR) {
5441                 /* Cannot expect anything... */
5442                 scan_commit(pRExC_state, data, minlenp, is_inf);
5443                 data->pos_min += 1;
5444                 data->pos_delta += 1;
5445                 data->cur_is_floating = 1; /* float */
5446             }
5447         }
5448         else if (REGNODE_SIMPLE(OP(scan))) {
5449
5450             if (flags & SCF_DO_SUBSTR) {
5451                 scan_commit(pRExC_state, data, minlenp, is_inf);
5452                 data->pos_min++;
5453             }
5454             min++;
5455             if (flags & SCF_DO_STCLASS) {
5456                 bool invert = 0;
5457                 SV* my_invlist = NULL;
5458                 U8 namedclass;
5459
5460                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5461                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5462
5463                 /* Some of the logic below assumes that switching
5464                    locale on will only add false positives. */
5465                 switch (OP(scan)) {
5466
5467                 default:
5468 #ifdef DEBUGGING
5469                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5470                                                                      OP(scan));
5471 #endif
5472                 case SANY:
5473                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5474                         ssc_match_all_cp(data->start_class);
5475                     break;
5476
5477                 case REG_ANY:
5478                     {
5479                         SV* REG_ANY_invlist = _new_invlist(2);
5480                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5481                                                             '\n');
5482                         if (flags & SCF_DO_STCLASS_OR) {
5483                             ssc_union(data->start_class,
5484                                       REG_ANY_invlist,
5485                                       TRUE /* TRUE => invert, hence all but \n
5486                                             */
5487                                       );
5488                         }
5489                         else if (flags & SCF_DO_STCLASS_AND) {
5490                             ssc_intersection(data->start_class,
5491                                              REG_ANY_invlist,
5492                                              TRUE  /* TRUE => invert */
5493                                              );
5494                             ssc_clear_locale(data->start_class);
5495                         }
5496                         SvREFCNT_dec_NN(REG_ANY_invlist);
5497                     }
5498                     break;
5499
5500                 case ANYOFD:
5501                 case ANYOFL:
5502                 case ANYOF:
5503                     if (flags & SCF_DO_STCLASS_AND)
5504                         ssc_and(pRExC_state, data->start_class,
5505                                 (regnode_charclass *) scan);
5506                     else
5507                         ssc_or(pRExC_state, data->start_class,
5508                                                           (regnode_charclass *) scan);
5509                     break;
5510
5511                 case NPOSIXL:
5512                     invert = 1;
5513                     /* FALLTHROUGH */
5514
5515                 case POSIXL:
5516                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5517                     if (flags & SCF_DO_STCLASS_AND) {
5518                         bool was_there = cBOOL(
5519                                           ANYOF_POSIXL_TEST(data->start_class,
5520                                                                  namedclass));
5521                         ANYOF_POSIXL_ZERO(data->start_class);
5522                         if (was_there) {    /* Do an AND */
5523                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5524                         }
5525                         /* No individual code points can now match */
5526                         data->start_class->invlist
5527                                                 = sv_2mortal(_new_invlist(0));
5528                     }
5529                     else {
5530                         int complement = namedclass + ((invert) ? -1 : 1);
5531
5532                         assert(flags & SCF_DO_STCLASS_OR);
5533
5534                         /* If the complement of this class was already there,
5535                          * the result is that they match all code points,
5536                          * (\d + \D == everything).  Remove the classes from
5537                          * future consideration.  Locale is not relevant in
5538                          * this case */
5539                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5540                             ssc_match_all_cp(data->start_class);
5541                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5542                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5543                         }
5544                         else {  /* The usual case; just add this class to the
5545                                    existing set */
5546                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5547                         }
5548                     }
5549                     break;
5550
5551                 case NPOSIXA:   /* For these, we always know the exact set of
5552                                    what's matched */
5553                     invert = 1;
5554                     /* FALLTHROUGH */
5555                 case POSIXA:
5556                     if (FLAGS(scan) == _CC_ASCII) {
5557                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5558                     }
5559                     else {
5560                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5561                                               PL_XPosix_ptrs[_CC_ASCII],
5562                                               &my_invlist);
5563                     }
5564                     goto join_posix;
5565
5566                 case NPOSIXD:
5567                 case NPOSIXU:
5568                     invert = 1;
5569                     /* FALLTHROUGH */
5570                 case POSIXD:
5571                 case POSIXU:
5572                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5573
5574                     /* NPOSIXD matches all upper Latin1 code points unless the
5575                      * target string being matched is UTF-8, which is
5576                      * unknowable until match time.  Since we are going to
5577                      * invert, we want to get rid of all of them so that the
5578                      * inversion will match all */
5579                     if (OP(scan) == NPOSIXD) {
5580                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5581                                           &my_invlist);
5582                     }
5583
5584                   join_posix:
5585
5586                     if (flags & SCF_DO_STCLASS_AND) {
5587                         ssc_intersection(data->start_class, my_invlist, invert);
5588                         ssc_clear_locale(data->start_class);
5589                     }
5590                     else {
5591                         assert(flags & SCF_DO_STCLASS_OR);
5592                         ssc_union(data->start_class, my_invlist, invert);
5593                     }
5594                     SvREFCNT_dec(my_invlist);
5595                 }
5596                 if (flags & SCF_DO_STCLASS_OR)
5597                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5598                 flags &= ~SCF_DO_STCLASS;
5599             }
5600         }
5601         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5602             data->flags |= (OP(scan) == MEOL
5603                             ? SF_BEFORE_MEOL
5604                             : SF_BEFORE_SEOL);
5605             scan_commit(pRExC_state, data, minlenp, is_inf);
5606
5607         }
5608         else if (  PL_regkind[OP(scan)] == BRANCHJ
5609                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5610                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5611                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5612         {
5613             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5614                 || OP(scan) == UNLESSM )
5615             {
5616                 /* Negative Lookahead/lookbehind
5617                    In this case we can't do fixed string optimisation.
5618                 */
5619
5620                 SSize_t deltanext, minnext, fake = 0;
5621                 regnode *nscan;
5622                 regnode_ssc intrnl;
5623                 int f = 0;
5624
5625                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5626                 if (data) {
5627                     data_fake.whilem_c = data->whilem_c;
5628                     data_fake.last_closep = data->last_closep;
5629                 }
5630                 else
5631                     data_fake.last_closep = &fake;
5632                 data_fake.pos_delta = delta;
5633                 if ( flags & SCF_DO_STCLASS && !scan->flags
5634                      && OP(scan) == IFMATCH ) { /* Lookahead */
5635                     ssc_init(pRExC_state, &intrnl);
5636                     data_fake.start_class = &intrnl;
5637                     f |= SCF_DO_STCLASS_AND;
5638                 }
5639                 if (flags & SCF_WHILEM_VISITED_POS)
5640                     f |= SCF_WHILEM_VISITED_POS;
5641                 next = regnext(scan);
5642                 nscan = NEXTOPER(NEXTOPER(scan));
5643                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5644                                       last, &data_fake, stopparen,
5645                                       recursed_depth, NULL, f, depth+1);
5646                 if (scan->flags) {
5647                     if (deltanext) {
5648                         FAIL("Variable length lookbehind not implemented");
5649                     }
5650                     else if (minnext > (I32)U8_MAX) {
5651                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5652                               (UV)U8_MAX);
5653                     }
5654                     scan->flags = (U8)minnext;
5655                 }
5656                 if (data) {
5657                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5658                         pars++;
5659                     if (data_fake.flags & SF_HAS_EVAL)
5660                         data->flags |= SF_HAS_EVAL;
5661                     data->whilem_c = data_fake.whilem_c;
5662                 }
5663                 if (f & SCF_DO_STCLASS_AND) {
5664                     if (flags & SCF_DO_STCLASS_OR) {
5665                         /* OR before, AND after: ideally we would recurse with
5666                          * data_fake to get the AND applied by study of the
5667                          * remainder of the pattern, and then derecurse;
5668                          * *** HACK *** for now just treat as "no information".
5669                          * See [perl #56690].
5670                          */
5671                         ssc_init(pRExC_state, data->start_class);
5672                     }  else {
5673                         /* AND before and after: combine and continue.  These
5674                          * assertions are zero-length, so can match an EMPTY
5675                          * string */
5676                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5677                         ANYOF_FLAGS(data->start_class)
5678                                                    |= SSC_MATCHES_EMPTY_STRING;
5679                     }
5680                 }
5681             }
5682 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5683             else {
5684                 /* Positive Lookahead/lookbehind
5685                    In this case we can do fixed string optimisation,
5686                    but we must be careful about it. Note in the case of
5687                    lookbehind the positions will be offset by the minimum
5688                    length of the pattern, something we won't know about
5689                    until after the recurse.
5690                 */
5691                 SSize_t deltanext, fake = 0;
5692                 regnode *nscan;
5693                 regnode_ssc intrnl;
5694                 int f = 0;
5695                 /* We use SAVEFREEPV so that when the full compile
5696                     is finished perl will clean up the allocated
5697                     minlens when it's all done. This way we don't
5698                     have to worry about freeing them when we know
5699                     they wont be used, which would be a pain.
5700                  */
5701                 SSize_t *minnextp;
5702                 Newx( minnextp, 1, SSize_t );
5703                 SAVEFREEPV(minnextp);
5704
5705                 if (data) {
5706                     StructCopy(data, &data_fake, scan_data_t);
5707                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5708                         f |= SCF_DO_SUBSTR;
5709                         if (scan->flags)
5710                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5711                         data_fake.last_found=newSVsv(data->last_found);
5712                     }
5713                 }
5714                 else
5715                     data_fake.last_closep = &fake;
5716                 data_fake.flags = 0;
5717                 data_fake.substrs[0].flags = 0;
5718                 data_fake.substrs[1].flags = 0;
5719                 data_fake.pos_delta = delta;
5720                 if (is_inf)
5721                     data_fake.flags |= SF_IS_INF;
5722                 if ( flags & SCF_DO_STCLASS && !scan->flags
5723                      && OP(scan) == IFMATCH ) { /* Lookahead */
5724                     ssc_init(pRExC_state, &intrnl);
5725                     data_fake.start_class = &intrnl;
5726                     f |= SCF_DO_STCLASS_AND;
5727                 }
5728                 if (flags & SCF_WHILEM_VISITED_POS)
5729                     f |= SCF_WHILEM_VISITED_POS;
5730                 next = regnext(scan);
5731                 nscan = NEXTOPER(NEXTOPER(scan));
5732
5733                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5734                                         &deltanext, last, &data_fake,
5735                                         stopparen, recursed_depth, NULL,
5736                                         f,depth+1);
5737                 if (scan->flags) {
5738                     if (deltanext) {
5739                         FAIL("Variable length lookbehind not implemented");
5740                     }
5741                     else if (*minnextp > (I32)U8_MAX) {
5742                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5743                               (UV)U8_MAX);
5744                     }
5745                     scan->flags = (U8)*minnextp;
5746                 }
5747
5748                 *minnextp += min;
5749
5750                 if (f & SCF_DO_STCLASS_AND) {
5751                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5752                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5753                 }
5754                 if (data) {
5755                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5756                         pars++;
5757                     if (data_fake.flags & SF_HAS_EVAL)
5758                         data->flags |= SF_HAS_EVAL;
5759                     data->whilem_c = data_fake.whilem_c;
5760                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5761                         int i;
5762                         if (RExC_rx->minlen<*minnextp)
5763                             RExC_rx->minlen=*minnextp;
5764                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5765                         SvREFCNT_dec_NN(data_fake.last_found);
5766
5767                         for (i = 0; i < 2; i++) {
5768                             if (data_fake.substrs[i].minlenp != minlenp) {
5769                                 data->substrs[i].min_offset =
5770                                             data_fake.substrs[i].min_offset;
5771                                 data->substrs[i].max_offset =
5772                                             data_fake.substrs[i].max_offset;
5773                                 data->substrs[i].minlenp =
5774                                             data_fake.substrs[i].minlenp;
5775                                 data->substrs[i].lookbehind += scan->flags;
5776                             }
5777                         }
5778                     }
5779                 }
5780             }
5781 #endif
5782         }
5783
5784         else if (OP(scan) == OPEN) {
5785             if (stopparen != (I32)ARG(scan))
5786                 pars++;
5787         }
5788         else if (OP(scan) == CLOSE) {
5789             if (stopparen == (I32)ARG(scan)) {
5790                 break;
5791             }
5792             if ((I32)ARG(scan) == is_par) {
5793                 next = regnext(scan);
5794
5795                 if ( next && (OP(next) != WHILEM) && next < last)
5796                     is_par = 0;         /* Disable optimization */
5797             }
5798             if (data)
5799                 *(data->last_closep) = ARG(scan);
5800         }
5801         else if (OP(scan) == EVAL) {
5802                 if (data)
5803                     data->flags |= SF_HAS_EVAL;
5804         }
5805         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5806             if (flags & SCF_DO_SUBSTR) {
5807                 scan_commit(pRExC_state, data, minlenp, is_inf);
5808                 flags &= ~SCF_DO_SUBSTR;
5809             }
5810             if (data && OP(scan)==ACCEPT) {
5811                 data->flags |= SCF_SEEN_ACCEPT;
5812                 if (stopmin > min)
5813                     stopmin = min;
5814             }
5815         }
5816         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5817         {
5818                 if (flags & SCF_DO_SUBSTR) {
5819                     scan_commit(pRExC_state, data, minlenp, is_inf);
5820                     data->cur_is_floating = 1; /* float */
5821                 }
5822                 is_inf = is_inf_internal = 1;
5823                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5824                     ssc_anything(data->start_class);
5825                 flags &= ~SCF_DO_STCLASS;
5826         }
5827         else if (OP(scan) == GPOS) {
5828             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5829                 !(delta || is_inf || (data && data->pos_delta)))
5830             {
5831                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5832                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5833                 if (RExC_rx->gofs < (STRLEN)min)
5834                     RExC_rx->gofs = min;
5835             } else {
5836                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5837                 RExC_rx->gofs = 0;
5838             }
5839         }
5840 #ifdef TRIE_STUDY_OPT
5841 #ifdef FULL_TRIE_STUDY
5842         else if (PL_regkind[OP(scan)] == TRIE) {
5843             /* NOTE - There is similar code to this block above for handling
5844                BRANCH nodes on the initial study.  If you change stuff here
5845                check there too. */
5846             regnode *trie_node= scan;
5847             regnode *tail= regnext(scan);
5848             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5849             SSize_t max1 = 0, min1 = SSize_t_MAX;
5850             regnode_ssc accum;
5851
5852             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5853                 /* Cannot merge strings after this. */
5854                 scan_commit(pRExC_state, data, minlenp, is_inf);
5855             }
5856             if (flags & SCF_DO_STCLASS)
5857                 ssc_init_zero(pRExC_state, &accum);
5858
5859             if (!trie->jump) {
5860                 min1= trie->minlen;
5861                 max1= trie->maxlen;
5862             } else {
5863                 const regnode *nextbranch= NULL;
5864                 U32 word;
5865
5866                 for ( word=1 ; word <= trie->wordcount ; word++)
5867                 {
5868                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5869                     regnode_ssc this_class;
5870
5871                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5872                     if (data) {
5873                         data_fake.whilem_c = data->whilem_c;
5874                         data_fake.last_closep = data->last_closep;
5875                     }
5876                     else
5877                         data_fake.last_closep = &fake;
5878                     data_fake.pos_delta = delta;
5879                     if (flags & SCF_DO_STCLASS) {
5880                         ssc_init(pRExC_state, &this_class);
5881                         data_fake.start_class = &this_class;
5882                         f = SCF_DO_STCLASS_AND;
5883                     }
5884                     if (flags & SCF_WHILEM_VISITED_POS)
5885                         f |= SCF_WHILEM_VISITED_POS;
5886
5887                     if (trie->jump[word]) {
5888                         if (!nextbranch)
5889                             nextbranch = trie_node + trie->jump[0];
5890                         scan= trie_node + trie->jump[word];
5891                         /* We go from the jump point to the branch that follows
5892                            it. Note this means we need the vestigal unused
5893                            branches even though they arent otherwise used. */
5894                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5895                             &deltanext, (regnode *)nextbranch, &data_fake,
5896                             stopparen, recursed_depth, NULL, f,depth+1);
5897                     }
5898                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5899                         nextbranch= regnext((regnode*)nextbranch);
5900
5901                     if (min1 > (SSize_t)(minnext + trie->minlen))
5902                         min1 = minnext + trie->minlen;
5903                     if (deltanext == SSize_t_MAX) {
5904                         is_inf = is_inf_internal = 1;
5905                         max1 = SSize_t_MAX;
5906                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5907                         max1 = minnext + deltanext + trie->maxlen;
5908
5909                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5910                         pars++;
5911                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5912                         if ( stopmin > min + min1)
5913                             stopmin = min + min1;
5914                         flags &= ~SCF_DO_SUBSTR;
5915                         if (data)
5916                             data->flags |= SCF_SEEN_ACCEPT;
5917                     }
5918                     if (data) {
5919                         if (data_fake.flags & SF_HAS_EVAL)
5920                             data->flags |= SF_HAS_EVAL;
5921                         data->whilem_c = data_fake.whilem_c;
5922                     }
5923                     if (flags & SCF_DO_STCLASS)
5924                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5925                 }
5926             }
5927             if (flags & SCF_DO_SUBSTR) {
5928                 data->pos_min += min1;
5929                 data->pos_delta += max1 - min1;
5930                 if (max1 != min1 || is_inf)
5931                     data->cur_is_floating = 1; /* float */
5932             }
5933             min += min1;
5934             if (delta != SSize_t_MAX)
5935                 delta += max1 - min1;
5936             if (flags & SCF_DO_STCLASS_OR) {
5937                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5938                 if (min1) {
5939                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5940                     flags &= ~SCF_DO_STCLASS;
5941                 }
5942             }
5943             else if (flags & SCF_DO_STCLASS_AND) {
5944                 if (min1) {
5945                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5946                     flags &= ~SCF_DO_STCLASS;
5947                 }
5948                 else {
5949                     /* Switch to OR mode: cache the old value of
5950                      * data->start_class */
5951                     INIT_AND_WITHP;
5952                     StructCopy(data->start_class, and_withp, regnode_ssc);
5953                     flags &= ~SCF_DO_STCLASS_AND;
5954                     StructCopy(&accum, data->start_class, regnode_ssc);
5955                     flags |= SCF_DO_STCLASS_OR;
5956                 }
5957             }
5958             scan= tail;
5959             continue;
5960         }
5961 #else
5962         else if (PL_regkind[OP(scan)] == TRIE) {
5963             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5964             U8*bang=NULL;
5965
5966             min += trie->minlen;
5967             delta += (trie->maxlen - trie->minlen);
5968             flags &= ~SCF_DO_STCLASS; /* xxx */
5969             if (flags & SCF_DO_SUBSTR) {
5970                 /* Cannot expect anything... */
5971                 scan_commit(pRExC_state, data, minlenp, is_inf);
5972                 data->pos_min += trie->minlen;
5973                 data->pos_delta += (trie->maxlen - trie->minlen);
5974                 if (trie->maxlen != trie->minlen)
5975                     data->cur_is_floating = 1; /* float */
5976             }
5977             if (trie->jump) /* no more substrings -- for now /grr*/
5978                flags &= ~SCF_DO_SUBSTR;
5979         }
5980 #endif /* old or new */
5981 #endif /* TRIE_STUDY_OPT */
5982
5983         /* Else: zero-length, ignore. */
5984         scan = regnext(scan);
5985     }
5986
5987   finish:
5988     if (frame) {
5989         /* we need to unwind recursion. */
5990         depth = depth - 1;
5991
5992         DEBUG_STUDYDATA("frame-end", data, depth, is_inf);
5993         DEBUG_PEEP("fend", scan, depth, flags);
5994
5995         /* restore previous context */
5996         last = frame->last_regnode;
5997         scan = frame->next_regnode;
5998         stopparen = frame->stopparen;
5999         recursed_depth = frame->prev_recursed_depth;
6000
6001         RExC_frame_last = frame->prev_frame;
6002         frame = frame->this_prev_frame;
6003         goto fake_study_recurse;
6004     }
6005
6006     assert(!frame);
6007     DEBUG_STUDYDATA("pre-fin", data, depth, is_inf);
6008
6009     *scanp = scan;
6010     *deltap = is_inf_internal ? SSize_t_MAX : delta;
6011
6012     if (flags & SCF_DO_SUBSTR && is_inf)
6013         data->pos_delta = SSize_t_MAX - data->pos_min;
6014     if (is_par > (I32)U8_MAX)
6015         is_par = 0;
6016     if (is_par && pars==1 && data) {
6017         data->flags |= SF_IN_PAR;
6018         data->flags &= ~SF_HAS_PAR;
6019     }
6020     else if (pars && data) {
6021         data->flags |= SF_HAS_PAR;
6022         data->flags &= ~SF_IN_PAR;
6023     }
6024     if (flags & SCF_DO_STCLASS_OR)
6025         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6026     if (flags & SCF_TRIE_RESTUDY)
6027         data->flags |=  SCF_TRIE_RESTUDY;
6028
6029     DEBUG_STUDYDATA("post-fin", data, depth, is_inf);
6030
6031     {
6032         SSize_t final_minlen= min < stopmin ? min : stopmin;
6033
6034         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
6035             if (final_minlen > SSize_t_MAX - delta)
6036                 RExC_maxlen = SSize_t_MAX;
6037             else if (RExC_maxlen < final_minlen + delta)
6038                 RExC_maxlen = final_minlen + delta;
6039         }
6040         return final_minlen;
6041     }
6042     NOT_REACHED; /* NOTREACHED */
6043 }
6044
6045 STATIC U32
6046 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
6047 {
6048     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
6049
6050     PERL_ARGS_ASSERT_ADD_DATA;
6051
6052     Renewc(RExC_rxi->data,
6053            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6054            char, struct reg_data);
6055     if(count)
6056         Renew(RExC_rxi->data->what, count + n, U8);
6057     else
6058         Newx(RExC_rxi->data->what, n, U8);
6059     RExC_rxi->data->count = count + n;
6060     Copy(s, RExC_rxi->data->what + count, n, U8);
6061     return count;
6062 }
6063
6064 /*XXX: todo make this not included in a non debugging perl, but appears to be
6065  * used anyway there, in 'use re' */
6066 #ifndef PERL_IN_XSUB_RE
6067 void
6068 Perl_reginitcolors(pTHX)
6069 {
6070     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6071     if (s) {
6072         char *t = savepv(s);
6073         int i = 0;
6074         PL_colors[0] = t;
6075         while (++i < 6) {
6076             t = strchr(t, '\t');
6077             if (t) {
6078                 *t = '\0';
6079                 PL_colors[i] = ++t;
6080             }
6081             else
6082                 PL_colors[i] = t = (char *)"";
6083         }
6084     } else {
6085         int i = 0;
6086         while (i < 6)
6087             PL_colors[i++] = (char *)"";
6088     }
6089     PL_colorset = 1;
6090 }
6091 #endif
6092
6093
6094 #ifdef TRIE_STUDY_OPT
6095 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6096     STMT_START {                                            \
6097         if (                                                \
6098               (data.flags & SCF_TRIE_RESTUDY)               \
6099               && ! restudied++                              \
6100         ) {                                                 \
6101             dOsomething;                                    \
6102             goto reStudy;                                   \
6103         }                                                   \
6104     } STMT_END
6105 #else
6106 #define CHECK_RESTUDY_GOTO_butfirst
6107 #endif
6108
6109 /*
6110  * pregcomp - compile a regular expression into internal code
6111  *
6112  * Decides which engine's compiler to call based on the hint currently in
6113  * scope
6114  */
6115
6116 #ifndef PERL_IN_XSUB_RE
6117
6118 /* return the currently in-scope regex engine (or the default if none)  */
6119
6120 regexp_engine const *
6121 Perl_current_re_engine(pTHX)
6122 {
6123     if (IN_PERL_COMPILETIME) {
6124         HV * const table = GvHV(PL_hintgv);
6125         SV **ptr;
6126
6127         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6128             return &PL_core_reg_engine;
6129         ptr = hv_fetchs(table, "regcomp", FALSE);
6130         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6131             return &PL_core_reg_engine;
6132         return INT2PTR(regexp_engine*,SvIV(*ptr));
6133     }
6134     else {
6135         SV *ptr;
6136         if (!PL_curcop->cop_hints_hash)
6137             return &PL_core_reg_engine;
6138         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6139         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6140             return &PL_core_reg_engine;
6141         return INT2PTR(regexp_engine*,SvIV(ptr));
6142     }
6143 }
6144
6145
6146 REGEXP *
6147 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6148 {
6149     regexp_engine const *eng = current_re_engine();
6150     GET_RE_DEBUG_FLAGS_DECL;
6151
6152     PERL_ARGS_ASSERT_PREGCOMP;
6153
6154     /* Dispatch a request to compile a regexp to correct regexp engine. */
6155     DEBUG_COMPILE_r({
6156         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6157                         PTR2UV(eng));
6158     });
6159     return CALLREGCOMP_ENG(eng, pattern, flags);
6160 }
6161 #endif
6162
6163 /* public(ish) entry point for the perl core's own regex compiling code.
6164  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6165  * pattern rather than a list of OPs, and uses the internal engine rather
6166  * than the current one */
6167
6168 REGEXP *
6169 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6170 {
6171     SV *pat = pattern; /* defeat constness! */
6172     PERL_ARGS_ASSERT_RE_COMPILE;
6173     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6174 #ifdef PERL_IN_XSUB_RE
6175                                 &my_reg_engine,
6176 #else
6177                                 &PL_core_reg_engine,
6178 #endif
6179                                 NULL, NULL, rx_flags, 0);
6180 }
6181
6182
6183 static void
6184 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6185 {
6186     int n;
6187
6188     if (--cbs->refcnt > 0)
6189         return;
6190     for (n = 0; n < cbs->count; n++) {
6191         REGEXP *rx = cbs->cb[n].src_regex;
6192         cbs->cb[n].src_regex = NULL;
6193         SvREFCNT_dec(rx);
6194     }
6195     Safefree(cbs->cb);
6196     Safefree(cbs);
6197 }
6198
6199
6200 static struct reg_code_blocks *
6201 S_alloc_code_blocks(pTHX_  int ncode)
6202 {
6203      struct reg_code_blocks *cbs;
6204     Newx(cbs, 1, struct reg_code_blocks);
6205     cbs->count = ncode;
6206     cbs->refcnt = 1;
6207     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6208     if (ncode)
6209         Newx(cbs->cb, ncode, struct reg_code_block);
6210     else
6211         cbs->cb = NULL;
6212     return cbs;
6213 }
6214
6215
6216 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6217  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6218  * point to the realloced string and length.
6219  *
6220  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6221  * stuff added */
6222
6223 static void
6224 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6225                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6226 {
6227     U8 *const src = (U8*)*pat_p;
6228     U8 *dst, *d;
6229     int n=0;
6230     STRLEN s = 0;
6231     bool do_end = 0;
6232     GET_RE_DEBUG_FLAGS_DECL;
6233
6234     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6235         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6236
6237     Newx(dst, *plen_p * 2 + 1, U8);
6238     d = dst;
6239
6240     while (s < *plen_p) {
6241         append_utf8_from_native_byte(src[s], &d);
6242
6243         if (n < num_code_blocks) {
6244             assert(pRExC_state->code_blocks);
6245             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6246                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6247                 assert(*(d - 1) == '(');
6248                 do_end = 1;
6249             }
6250             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6251                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6252                 assert(*(d - 1) == ')');
6253                 do_end = 0;
6254                 n++;
6255             }
6256         }
6257         s++;
6258     }
6259     *d = '\0';
6260     *plen_p = d - dst;
6261     *pat_p = (char*) dst;
6262     SAVEFREEPV(*pat_p);
6263     RExC_orig_utf8 = RExC_utf8 = 1;
6264 }
6265
6266
6267
6268 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6269  * while recording any code block indices, and handling overloading,
6270  * nested qr// objects etc.  If pat is null, it will allocate a new
6271  * string, or just return the first arg, if there's only one.
6272  *
6273  * Returns the malloced/updated pat.
6274  * patternp and pat_count is the array of SVs to be concatted;
6275  * oplist is the optional list of ops that generated the SVs;
6276  * recompile_p is a pointer to a boolean that will be set if
6277  *   the regex will need to be recompiled.
6278  * delim, if non-null is an SV that will be inserted between each element
6279  */
6280
6281 static SV*
6282 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6283                 SV *pat, SV ** const patternp, int pat_count,
6284                 OP *oplist, bool *recompile_p, SV *delim)
6285 {
6286     SV **svp;
6287     int n = 0;
6288     bool use_delim = FALSE;
6289     bool alloced = FALSE;
6290
6291     /* if we know we have at least two args, create an empty string,
6292      * then concatenate args to that. For no args, return an empty string */
6293     if (!pat && pat_count != 1) {
6294         pat = newSVpvs("");
6295         SAVEFREESV(pat);
6296         alloced = TRUE;
6297     }
6298
6299     for (svp = patternp; svp < patternp + pat_count; svp++) {
6300         SV *sv;
6301         SV *rx  = NULL;
6302         STRLEN orig_patlen = 0;
6303         bool code = 0;
6304         SV *msv = use_delim ? delim : *svp;
6305         if (!msv) msv = &PL_sv_undef;
6306
6307         /* if we've got a delimiter, we go round the loop twice for each
6308          * svp slot (except the last), using the delimiter the second
6309          * time round */
6310         if (use_delim) {
6311             svp--;
6312             use_delim = FALSE;
6313         }
6314         else if (delim)
6315             use_delim = TRUE;
6316
6317         if (SvTYPE(msv) == SVt_PVAV) {
6318             /* we've encountered an interpolated array within
6319              * the pattern, e.g. /...@a..../. Expand the list of elements,
6320              * then recursively append elements.
6321              * The code in this block is based on S_pushav() */
6322
6323             AV *const av = (AV*)msv;
6324             const SSize_t maxarg = AvFILL(av) + 1;
6325             SV **array;
6326
6327             if (oplist) {
6328                 assert(oplist->op_type == OP_PADAV
6329                     || oplist->op_type == OP_RV2AV);
6330                 oplist = OpSIBLING(oplist);
6331             }
6332
6333             if (SvRMAGICAL(av)) {
6334                 SSize_t i;
6335
6336                 Newx(array, maxarg, SV*);
6337                 SAVEFREEPV(array);
6338                 for (i=0; i < maxarg; i++) {
6339                     SV ** const svp = av_fetch(av, i, FALSE);
6340                     array[i] = svp ? *svp : &PL_sv_undef;
6341                 }
6342             }
6343             else
6344                 array = AvARRAY(av);
6345
6346             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6347                                 array, maxarg, NULL, recompile_p,
6348                                 /* $" */
6349                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6350
6351             continue;
6352         }
6353
6354
6355         /* we make the assumption here that each op in the list of
6356          * op_siblings maps to one SV pushed onto the stack,
6357          * except for code blocks, with have both an OP_NULL and
6358          * and OP_CONST.
6359          * This allows us to match up the list of SVs against the
6360          * list of OPs to find the next code block.
6361          *
6362          * Note that       PUSHMARK PADSV PADSV ..
6363          * is optimised to
6364          *                 PADRANGE PADSV  PADSV  ..
6365          * so the alignment still works. */
6366
6367         if (oplist) {
6368             if (oplist->op_type == OP_NULL
6369                 && (oplist->op_flags & OPf_SPECIAL))
6370             {
6371                 assert(n < pRExC_state->code_blocks->count);
6372                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6373                 pRExC_state->code_blocks->cb[n].block = oplist;
6374                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6375                 n++;
6376                 code = 1;
6377                 oplist = OpSIBLING(oplist); /* skip CONST */
6378                 assert(oplist);
6379             }
6380             oplist = OpSIBLING(oplist);;
6381         }
6382
6383         /* apply magic and QR overloading to arg */
6384
6385         SvGETMAGIC(msv);
6386         if (SvROK(msv) && SvAMAGIC(msv)) {
6387             SV *sv = AMG_CALLunary(msv, regexp_amg);
6388             if (sv) {
6389                 if (SvROK(sv))
6390                     sv = SvRV(sv);
6391                 if (SvTYPE(sv) != SVt_REGEXP)
6392                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6393                 msv = sv;
6394             }
6395         }
6396
6397         /* try concatenation overload ... */
6398         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6399                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6400         {
6401             sv_setsv(pat, sv);
6402             /* overloading involved: all bets are off over literal
6403              * code. Pretend we haven't seen it */
6404             if (n)
6405                 pRExC_state->code_blocks->count -= n;
6406             n = 0;
6407         }
6408         else  {
6409             /* ... or failing that, try "" overload */
6410             while (SvAMAGIC(msv)
6411                     && (sv = AMG_CALLunary(msv, string_amg))
6412                     && sv != msv
6413                     &&  !(   SvROK(msv)
6414                           && SvROK(sv)
6415                           && SvRV(msv) == SvRV(sv))
6416             ) {
6417                 msv = sv;
6418                 SvGETMAGIC(msv);
6419             }
6420             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6421                 msv = SvRV(msv);
6422
6423             if (pat) {
6424                 /* this is a partially unrolled
6425                  *     sv_catsv_nomg(pat, msv);
6426                  * that allows us to adjust code block indices if
6427                  * needed */
6428                 STRLEN dlen;
6429                 char *dst = SvPV_force_nomg(pat, dlen);
6430                 orig_patlen = dlen;
6431                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6432                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6433                     sv_setpvn(pat, dst, dlen);
6434                     SvUTF8_on(pat);
6435                 }
6436                 sv_catsv_nomg(pat, msv);
6437                 rx = msv;
6438             }
6439             else {
6440                 /* We have only one SV to process, but we need to verify
6441                  * it is properly null terminated or we will fail asserts
6442                  * later. In theory we probably shouldn't get such SV's,
6443                  * but if we do we should handle it gracefully. */
6444                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) ) {
6445                     /* not a string, or a string with a trailing null */
6446                     pat = msv;
6447                 } else {
6448                     /* a string with no trailing null, we need to copy it
6449                      * so it we have a trailing null */
6450                     pat = newSVsv(msv);
6451                 }
6452             }
6453
6454             if (code)
6455                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
6456         }
6457
6458         /* extract any code blocks within any embedded qr//'s */
6459         if (rx && SvTYPE(rx) == SVt_REGEXP
6460             && RX_ENGINE((REGEXP*)rx)->op_comp)
6461         {
6462
6463             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6464             if (ri->code_blocks && ri->code_blocks->count) {
6465                 int i;
6466                 /* the presence of an embedded qr// with code means
6467                  * we should always recompile: the text of the
6468                  * qr// may not have changed, but it may be a
6469                  * different closure than last time */
6470                 *recompile_p = 1;
6471                 if (pRExC_state->code_blocks) {
6472                     int new_count = pRExC_state->code_blocks->count
6473                             + ri->code_blocks->count;
6474                     Renew(pRExC_state->code_blocks->cb,
6475                             new_count, struct reg_code_block);
6476                     pRExC_state->code_blocks->count = new_count;
6477                 }
6478                 else
6479                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
6480                                                     ri->code_blocks->count);
6481
6482                 for (i=0; i < ri->code_blocks->count; i++) {
6483                     struct reg_code_block *src, *dst;
6484                     STRLEN offset =  orig_patlen
6485                         + ReANY((REGEXP *)rx)->pre_prefix;
6486                     assert(n < pRExC_state->code_blocks->count);
6487                     src = &ri->code_blocks->cb[i];
6488                     dst = &pRExC_state->code_blocks->cb[n];
6489                     dst->start      = src->start + offset;
6490                     dst->end        = src->end   + offset;
6491                     dst->block      = src->block;
6492                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6493                                             src->src_regex
6494                                                 ? src->src_regex
6495                                                 : (REGEXP*)rx);
6496                     n++;
6497                 }
6498             }
6499         }
6500     }
6501     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6502     if (alloced)
6503         SvSETMAGIC(pat);
6504
6505     return pat;
6506 }
6507
6508
6509
6510 /* see if there are any run-time code blocks in the pattern.
6511  * False positives are allowed */
6512
6513 static bool
6514 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6515                     char *pat, STRLEN plen)
6516 {
6517     int n = 0;
6518     STRLEN s;
6519     
6520     PERL_UNUSED_CONTEXT;
6521
6522     for (s = 0; s < plen; s++) {
6523         if (   pRExC_state->code_blocks
6524             && n < pRExC_state->code_blocks->count
6525             && s == pRExC_state->code_blocks->cb[n].start)
6526         {
6527             s = pRExC_state->code_blocks->cb[n].end;
6528             n++;
6529             continue;
6530         }
6531         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6532          * positives here */
6533         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6534             (pat[s+2] == '{'
6535                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6536         )
6537             return 1;
6538     }
6539     return 0;
6540 }
6541
6542 /* Handle run-time code blocks. We will already have compiled any direct
6543  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6544  * copy of it, but with any literal code blocks blanked out and
6545  * appropriate chars escaped; then feed it into
6546  *
6547  *    eval "qr'modified_pattern'"
6548  *
6549  * For example,
6550  *
6551  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6552  *
6553  * becomes
6554  *
6555  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6556  *
6557  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6558  * and merge them with any code blocks of the original regexp.
6559  *
6560  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6561  * instead, just save the qr and return FALSE; this tells our caller that
6562  * the original pattern needs upgrading to utf8.
6563  */
6564
6565 static bool
6566 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6567     char *pat, STRLEN plen)
6568 {
6569     SV *qr;
6570
6571     GET_RE_DEBUG_FLAGS_DECL;
6572
6573     if (pRExC_state->runtime_code_qr) {
6574         /* this is the second time we've been called; this should
6575          * only happen if the main pattern got upgraded to utf8
6576          * during compilation; re-use the qr we compiled first time
6577          * round (which should be utf8 too)
6578          */
6579         qr = pRExC_state->runtime_code_qr;
6580         pRExC_state->runtime_code_qr = NULL;
6581         assert(RExC_utf8 && SvUTF8(qr));
6582     }
6583     else {
6584         int n = 0;
6585         STRLEN s;
6586         char *p, *newpat;
6587         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
6588         SV *sv, *qr_ref;
6589         dSP;
6590
6591         /* determine how many extra chars we need for ' and \ escaping */
6592         for (s = 0; s < plen; s++) {
6593             if (pat[s] == '\'' || pat[s] == '\\')
6594                 newlen++;
6595         }
6596
6597         Newx(newpat, newlen, char);
6598         p = newpat;
6599         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6600
6601         for (s = 0; s < plen; s++) {
6602             if (   pRExC_state->code_blocks
6603                 && n < pRExC_state->code_blocks->count
6604                 && s == pRExC_state->code_blocks->cb[n].start)
6605             {
6606                 /* blank out literal code block */
6607                 assert(pat[s] == '(');
6608                 while (s <= pRExC_state->code_blocks->cb[n].end) {
6609                     *p++ = '_';
6610                     s++;
6611                 }
6612                 s--;
6613                 n++;
6614                 continue;
6615             }
6616             if (pat[s] == '\'' || pat[s] == '\\')
6617                 *p++ = '\\';
6618             *p++ = pat[s];
6619         }
6620         *p++ = '\'';
6621         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
6622             *p++ = 'x';
6623             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
6624                 *p++ = 'x';
6625             }
6626         }
6627         *p++ = '\0';
6628         DEBUG_COMPILE_r({
6629             Perl_re_printf( aTHX_
6630                 "%sre-parsing pattern for runtime code:%s %s\n",
6631                 PL_colors[4],PL_colors[5],newpat);
6632         });
6633
6634         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6635         Safefree(newpat);
6636
6637         ENTER;
6638         SAVETMPS;
6639         save_re_context();
6640         PUSHSTACKi(PERLSI_REQUIRE);
6641         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6642          * parsing qr''; normally only q'' does this. It also alters
6643          * hints handling */
6644         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6645         SvREFCNT_dec_NN(sv);
6646         SPAGAIN;
6647         qr_ref = POPs;
6648         PUTBACK;
6649         {
6650             SV * const errsv = ERRSV;
6651             if (SvTRUE_NN(errsv))
6652                 /* use croak_sv ? */
6653                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
6654         }
6655         assert(SvROK(qr_ref));
6656         qr = SvRV(qr_ref);
6657         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6658         /* the leaving below frees the tmp qr_ref.
6659          * Give qr a life of its own */
6660         SvREFCNT_inc(qr);
6661         POPSTACK;
6662         FREETMPS;
6663         LEAVE;
6664
6665     }
6666
6667     if (!RExC_utf8 && SvUTF8(qr)) {
6668         /* first time through; the pattern got upgraded; save the
6669          * qr for the next time through */
6670         assert(!pRExC_state->runtime_code_qr);
6671         pRExC_state->runtime_code_qr = qr;
6672         return 0;
6673     }
6674
6675
6676     /* extract any code blocks within the returned qr//  */
6677
6678
6679     /* merge the main (r1) and run-time (r2) code blocks into one */
6680     {
6681         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6682         struct reg_code_block *new_block, *dst;
6683         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6684         int i1 = 0, i2 = 0;
6685         int r1c, r2c;
6686
6687         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
6688         {
6689             SvREFCNT_dec_NN(qr);
6690             return 1;
6691         }
6692
6693         if (!r1->code_blocks)
6694             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
6695
6696         r1c = r1->code_blocks->count;
6697         r2c = r2->code_blocks->count;
6698
6699         Newx(new_block, r1c + r2c, struct reg_code_block);
6700
6701         dst = new_block;
6702
6703         while (i1 < r1c || i2 < r2c) {
6704             struct reg_code_block *src;
6705             bool is_qr = 0;
6706
6707             if (i1 == r1c) {
6708                 src = &r2->code_blocks->cb[i2++];
6709                 is_qr = 1;
6710             }
6711             else if (i2 == r2c)
6712                 src = &r1->code_blocks->cb[i1++];
6713             else if (  r1->code_blocks->cb[i1].start
6714                      < r2->code_blocks->cb[i2].start)
6715             {
6716                 src = &r1->code_blocks->cb[i1++];
6717                 assert(src->end < r2->code_blocks->cb[i2].start);
6718             }
6719             else {
6720                 assert(  r1->code_blocks->cb[i1].start
6721                        > r2->code_blocks->cb[i2].start);
6722                 src = &r2->code_blocks->cb[i2++];
6723                 is_qr = 1;
6724                 assert(src->end < r1->code_blocks->cb[i1].start);
6725             }
6726
6727             assert(pat[src->start] == '(');
6728             assert(pat[src->end]   == ')');
6729             dst->start      = src->start;
6730             dst->end        = src->end;
6731             dst->block      = src->block;
6732             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6733                                     : src->src_regex;
6734             dst++;
6735         }
6736         r1->code_blocks->count += r2c;
6737         Safefree(r1->code_blocks->cb);
6738         r1->code_blocks->cb = new_block;
6739     }
6740
6741     SvREFCNT_dec_NN(qr);
6742     return 1;
6743 }
6744
6745
6746 STATIC bool
6747 S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
6748                       struct reg_substr_datum  *rsd,
6749                       struct scan_data_substrs *sub,
6750                       STRLEN longest_length)
6751 {
6752     /* This is the common code for setting up the floating and fixed length
6753      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6754      * as to whether succeeded or not */
6755
6756     I32 t;
6757     SSize_t ml;
6758     bool eol  = cBOOL(sub->flags & SF_BEFORE_EOL);
6759     bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
6760
6761     if (! (longest_length
6762            || (eol /* Can't have SEOL and MULTI */
6763                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6764           )
6765             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6766         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6767     {
6768         return FALSE;
6769     }
6770
6771     /* copy the information about the longest from the reg_scan_data
6772         over to the program. */
6773     if (SvUTF8(sub->str)) {
6774         rsd->substr      = NULL;
6775         rsd->utf8_substr = sub->str;
6776     } else {
6777         rsd->substr      = sub->str;
6778         rsd->utf8_substr = NULL;
6779     }
6780     /* end_shift is how many chars that must be matched that
6781         follow this item. We calculate it ahead of time as once the
6782         lookbehind offset is added in we lose the ability to correctly
6783         calculate it.*/
6784     ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
6785     rsd->end_shift = ml - sub->min_offset
6786         - longest_length
6787             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
6788              * intead? - DAPM
6789             + (SvTAIL(sub->str) != 0)
6790             */
6791         + sub->lookbehind;
6792
6793     t = (eol/* Can't have SEOL and MULTI */
6794          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6795     fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
6796
6797     return TRUE;
6798 }
6799
6800 /*
6801  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6802  * regular expression into internal code.
6803  * The pattern may be passed either as:
6804  *    a list of SVs (patternp plus pat_count)
6805  *    a list of OPs (expr)
6806  * If both are passed, the SV list is used, but the OP list indicates
6807  * which SVs are actually pre-compiled code blocks
6808  *
6809  * The SVs in the list have magic and qr overloading applied to them (and
6810  * the list may be modified in-place with replacement SVs in the latter
6811  * case).
6812  *
6813  * If the pattern hasn't changed from old_re, then old_re will be
6814  * returned.
6815  *
6816  * eng is the current engine. If that engine has an op_comp method, then
6817  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6818  * do the initial concatenation of arguments and pass on to the external
6819  * engine.
6820  *
6821  * If is_bare_re is not null, set it to a boolean indicating whether the
6822  * arg list reduced (after overloading) to a single bare regex which has
6823  * been returned (i.e. /$qr/).
6824  *
6825  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6826  *
6827  * pm_flags contains the PMf_* flags, typically based on those from the
6828  * pm_flags field of the related PMOP. Currently we're only interested in
6829  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6830  *
6831  * We can't allocate space until we know how big the compiled form will be,
6832  * but we can't compile it (and thus know how big it is) until we've got a
6833  * place to put the code.  So we cheat:  we compile it twice, once with code
6834  * generation turned off and size counting turned on, and once "for real".
6835  * This also means that we don't allocate space until we are sure that the
6836  * thing really will compile successfully, and we never have to move the
6837  * code and thus invalidate pointers into it.  (Note that it has to be in
6838  * one piece because free() must be able to free it all.) [NB: not true in perl]
6839  *
6840  * Beware that the optimization-preparation code in here knows about some
6841  * of the structure of the compiled regexp.  [I'll say.]
6842  */
6843
6844 REGEXP *
6845 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6846                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6847                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6848 {
6849     REGEXP *rx;
6850     struct regexp *r;
6851     regexp_internal *ri;
6852     STRLEN plen;
6853     char *exp;
6854     regnode *scan;
6855     I32 flags;
6856     SSize_t minlen = 0;
6857     U32 rx_flags;
6858     SV *pat;
6859     SV** new_patternp = patternp;
6860
6861     /* these are all flags - maybe they should be turned
6862      * into a single int with different bit masks */
6863     I32 sawlookahead = 0;
6864     I32 sawplus = 0;
6865     I32 sawopen = 0;
6866     I32 sawminmod = 0;
6867
6868     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6869     bool recompile = 0;
6870     bool runtime_code = 0;
6871     scan_data_t data;
6872     RExC_state_t RExC_state;
6873     RExC_state_t * const pRExC_state = &RExC_state;
6874 #ifdef TRIE_STUDY_OPT
6875     int restudied = 0;
6876     RExC_state_t copyRExC_state;
6877 #endif
6878     GET_RE_DEBUG_FLAGS_DECL;
6879
6880     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6881
6882     DEBUG_r(if (!PL_colorset) reginitcolors());
6883
6884     /* Initialize these here instead of as-needed, as is quick and avoids
6885      * having to test them each time otherwise */
6886     if (! PL_AboveLatin1) {
6887 #ifdef DEBUGGING
6888         char * dump_len_string;
6889 #endif
6890
6891         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6892         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6893         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6894         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6895         PL_HasMultiCharFold =
6896                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6897
6898         /* This is calculated here, because the Perl program that generates the
6899          * static global ones doesn't currently have access to
6900          * NUM_ANYOF_CODE_POINTS */
6901         PL_InBitmap = _new_invlist(2);
6902         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6903                                                     NUM_ANYOF_CODE_POINTS - 1);
6904 #ifdef DEBUGGING
6905         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6906         if (   ! dump_len_string
6907             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6908         {
6909             PL_dump_re_max_len = 0;
6910         }
6911 #endif
6912     }
6913
6914     pRExC_state->warn_text = NULL;
6915     pRExC_state->code_blocks = NULL;
6916
6917     if (is_bare_re)
6918         *is_bare_re = FALSE;
6919
6920     if (expr && (expr->op_type == OP_LIST ||
6921                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6922         /* allocate code_blocks if needed */
6923         OP *o;
6924         int ncode = 0;
6925
6926         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6927             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6928                 ncode++; /* count of DO blocks */
6929
6930         if (ncode)
6931             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
6932     }
6933
6934     if (!pat_count) {
6935         /* compile-time pattern with just OP_CONSTs and DO blocks */
6936
6937         int n;
6938         OP *o;
6939
6940         /* find how many CONSTs there are */
6941         assert(expr);
6942         n = 0;
6943         if (expr->op_type == OP_CONST)
6944             n = 1;
6945         else
6946             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6947                 if (o->op_type == OP_CONST)
6948                     n++;
6949             }
6950
6951         /* fake up an SV array */
6952
6953         assert(!new_patternp);
6954         Newx(new_patternp, n, SV*);
6955         SAVEFREEPV(new_patternp);
6956         pat_count = n;
6957
6958         n = 0;
6959         if (expr->op_type == OP_CONST)
6960             new_patternp[n] = cSVOPx_sv(expr);
6961         else
6962             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6963                 if (o->op_type == OP_CONST)
6964                     new_patternp[n++] = cSVOPo_sv;
6965             }
6966
6967     }
6968
6969     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6970         "Assembling pattern from %d elements%s\n", pat_count,
6971             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6972
6973     /* set expr to the first arg op */
6974
6975     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
6976          && expr->op_type != OP_CONST)
6977     {
6978             expr = cLISTOPx(expr)->op_first;
6979             assert(   expr->op_type == OP_PUSHMARK
6980                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6981                    || expr->op_type == OP_PADRANGE);
6982             expr = OpSIBLING(expr);
6983     }
6984
6985     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6986                         expr, &recompile, NULL);
6987
6988     /* handle bare (possibly after overloading) regex: foo =~ $re */
6989     {
6990         SV *re = pat;
6991         if (SvROK(re))
6992             re = SvRV(re);
6993         if (SvTYPE(re) == SVt_REGEXP) {
6994             if (is_bare_re)
6995                 *is_bare_re = TRUE;
6996             SvREFCNT_inc(re);
6997             DEBUG_PARSE_r(Perl_re_printf( aTHX_
6998                 "Precompiled pattern%s\n",
6999                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7000
7001             return (REGEXP*)re;
7002         }
7003     }
7004
7005     exp = SvPV_nomg(pat, plen);
7006
7007     if (!eng->op_comp) {
7008         if ((SvUTF8(pat) && IN_BYTES)
7009                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
7010         {
7011             /* make a temporary copy; either to convert to bytes,
7012              * or to avoid repeating get-magic / overloaded stringify */
7013             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
7014                                         (IN_BYTES ? 0 : SvUTF8(pat)));
7015         }
7016         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
7017     }
7018
7019     /* ignore the utf8ness if the pattern is 0 length */
7020     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
7021
7022     RExC_uni_semantics = 0;
7023     RExC_seen_unfolded_sharp_s = 0;
7024     RExC_contains_locale = 0;
7025     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
7026     RExC_study_started = 0;
7027     pRExC_state->runtime_code_qr = NULL;
7028     RExC_frame_head= NULL;
7029     RExC_frame_last= NULL;
7030     RExC_frame_count= 0;
7031
7032     DEBUG_r({
7033         RExC_mysv1= sv_newmortal();
7034         RExC_mysv2= sv_newmortal();
7035     });
7036     DEBUG_COMPILE_r({
7037             SV *dsv= sv_newmortal();
7038             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
7039             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
7040                           PL_colors[4],PL_colors[5],s);
7041         });
7042
7043   redo_first_pass:
7044     /* we jump here if we have to recompile, e.g., from upgrading the pattern
7045      * to utf8 */
7046
7047     if ((pm_flags & PMf_USE_RE_EVAL)
7048                 /* this second condition covers the non-regex literal case,
7049                  * i.e.  $foo =~ '(?{})'. */
7050                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
7051     )
7052         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
7053
7054     /* return old regex if pattern hasn't changed */
7055     /* XXX: note in the below we have to check the flags as well as the
7056      * pattern.
7057      *
7058      * Things get a touch tricky as we have to compare the utf8 flag
7059      * independently from the compile flags.  */
7060
7061     if (   old_re
7062         && !recompile
7063         && !!RX_UTF8(old_re) == !!RExC_utf8
7064         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7065         && RX_PRECOMP(old_re)
7066         && RX_PRELEN(old_re) == plen
7067         && memEQ(RX_PRECOMP(old_re), exp, plen)
7068         && !runtime_code /* with runtime code, always recompile */ )
7069     {
7070         return old_re;
7071     }
7072
7073     rx_flags = orig_rx_flags;
7074
7075     if (   initial_charset == REGEX_DEPENDS_CHARSET
7076         && (RExC_utf8 ||RExC_uni_semantics))
7077     {
7078
7079         /* Set to use unicode semantics if the pattern is in utf8 and has the
7080          * 'depends' charset specified, as it means unicode when utf8  */
7081         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7082     }
7083
7084     RExC_precomp = exp;
7085     RExC_precomp_adj = 0;
7086     RExC_flags = rx_flags;
7087     RExC_pm_flags = pm_flags;
7088
7089     if (runtime_code) {
7090         assert(TAINTING_get || !TAINT_get);
7091         if (TAINT_get)
7092             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7093
7094         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7095             /* whoops, we have a non-utf8 pattern, whilst run-time code
7096              * got compiled as utf8. Try again with a utf8 pattern */
7097             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7098                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7099             goto redo_first_pass;
7100         }
7101     }
7102     assert(!pRExC_state->runtime_code_qr);
7103
7104     RExC_sawback = 0;
7105
7106     RExC_seen = 0;
7107     RExC_maxlen = 0;
7108     RExC_in_lookbehind = 0;
7109     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7110     RExC_extralen = 0;
7111 #ifdef EBCDIC
7112     RExC_recode_x_to_native = 0;
7113 #endif
7114     RExC_in_multi_char_class = 0;
7115
7116     /* First pass: determine size, legality. */
7117     RExC_parse = exp;
7118     RExC_start = RExC_adjusted_start = exp;
7119     RExC_end = exp + plen;
7120     RExC_precomp_end = RExC_end;
7121     RExC_naughty = 0;
7122     RExC_npar = 1;
7123     RExC_nestroot = 0;
7124     RExC_size = 0L;
7125     RExC_emit = (regnode *) &RExC_emit_dummy;
7126     RExC_whilem_seen = 0;
7127     RExC_open_parens = NULL;
7128     RExC_close_parens = NULL;
7129     RExC_end_op = NULL;
7130     RExC_paren_names = NULL;
7131 #ifdef DEBUGGING
7132     RExC_paren_name_list = NULL;
7133 #endif
7134     RExC_recurse = NULL;
7135     RExC_study_chunk_recursed = NULL;
7136     RExC_study_chunk_recursed_bytes= 0;
7137     RExC_recurse_count = 0;
7138     pRExC_state->code_index = 0;
7139
7140     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7141      * code makes sure the final byte is an uncounted NUL.  But should this
7142      * ever not be the case, lots of things could read beyond the end of the
7143      * buffer: loops like
7144      *      while(isFOO(*RExC_parse)) RExC_parse++;
7145      *      strchr(RExC_parse, "foo");
7146      * etc.  So it is worth noting. */
7147     assert(*RExC_end == '\0');
7148
7149     DEBUG_PARSE_r(
7150         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7151         RExC_lastnum=0;
7152         RExC_lastparse=NULL;
7153     );
7154
7155     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7156         /* It's possible to write a regexp in ascii that represents Unicode
7157         codepoints outside of the byte range, such as via \x{100}. If we
7158         detect such a sequence we have to convert the entire pattern to utf8
7159         and then recompile, as our sizing calculation will have been based
7160         on 1 byte == 1 character, but we will need to use utf8 to encode
7161         at least some part of the pattern, and therefore must convert the whole
7162         thing.
7163         -- dmq */
7164         if (flags & RESTART_PASS1) {
7165             if (flags & NEED_UTF8) {
7166                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7167                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7168             }
7169             else {
7170                 DEBUG_PARSE_r(Perl_re_printf( aTHX_
7171                 "Need to redo pass 1\n"));
7172             }
7173
7174             goto redo_first_pass;
7175         }
7176         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
7177     }
7178
7179     DEBUG_PARSE_r({
7180         Perl_re_printf( aTHX_
7181             "Required size %" IVdf " nodes\n"
7182             "Starting second pass (creation)\n",
7183             (IV)RExC_size);
7184         RExC_lastnum=0;
7185         RExC_lastparse=NULL;
7186     });
7187
7188     /* The first pass could have found things that force Unicode semantics */
7189     if ((RExC_utf8 || RExC_uni_semantics)
7190          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7191     {
7192         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7193     }
7194
7195     /* Small enough for pointer-storage convention?
7196        If extralen==0, this means that we will not need long jumps. */
7197     if (RExC_size >= 0x10000L && RExC_extralen)
7198         RExC_size += RExC_extralen;
7199     else
7200         RExC_extralen = 0;
7201     if (RExC_whilem_seen > 15)
7202         RExC_whilem_seen = 15;
7203
7204     /* Allocate space and zero-initialize. Note, the two step process
7205        of zeroing when in debug mode, thus anything assigned has to
7206        happen after that */
7207     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7208     r = ReANY(rx);
7209     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7210          char, regexp_internal);
7211     if ( r == NULL || ri == NULL )
7212         FAIL("Regexp out of space");
7213 #ifdef DEBUGGING
7214     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7215     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7216          char);
7217 #else
7218     /* bulk initialize base fields with 0. */
7219     Zero(ri, sizeof(regexp_internal), char);
7220 #endif
7221
7222     /* non-zero initialization begins here */
7223     RXi_SET( r, ri );
7224     r->engine= eng;
7225     r->extflags = rx_flags;
7226     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7227
7228     if (pm_flags & PMf_IS_QR) {
7229         ri->code_blocks = pRExC_state->code_blocks;
7230         if (ri->code_blocks)
7231             ri->code_blocks->refcnt++;
7232     }
7233
7234     {
7235         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7236         bool has_charset = (get_regex_charset(r->extflags)
7237                                                     != REGEX_DEPENDS_CHARSET);
7238
7239         /* The caret is output if there are any defaults: if not all the STD
7240          * flags are set, or if no character set specifier is needed */
7241         bool has_default =
7242                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7243                     || ! has_charset);
7244         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7245                                                    == REG_RUN_ON_COMMENT_SEEN);
7246         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7247                             >> RXf_PMf_STD_PMMOD_SHIFT);
7248         const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7249         char *p;
7250
7251         /* We output all the necessary flags; we never output a minus, as all
7252          * those are defaults, so are
7253          * covered by the caret */
7254         const STRLEN wraplen = plen + has_p + has_runon
7255             + has_default       /* If needs a caret */
7256             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7257
7258                 /* If needs a character set specifier */
7259             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7260             + (sizeof("(?:)") - 1);
7261
7262         /* make sure PL_bitcount bounds not exceeded */
7263         assert(sizeof(STD_PAT_MODS) <= 8);
7264
7265         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
7266         SvPOK_on(rx);
7267         if (RExC_utf8)
7268             SvFLAGS(rx) |= SVf_UTF8;
7269         *p++='('; *p++='?';
7270
7271         /* If a default, cover it using the caret */
7272         if (has_default) {
7273             *p++= DEFAULT_PAT_MOD;
7274         }
7275         if (has_charset) {
7276             STRLEN len;
7277             const char* const name = get_regex_charset_name(r->extflags, &len);
7278             Copy(name, p, len, char);
7279             p += len;
7280         }
7281         if (has_p)
7282             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7283         {
7284             char ch;
7285             while((ch = *fptr++)) {
7286                 if(reganch & 1)
7287                     *p++ = ch;
7288                 reganch >>= 1;
7289             }
7290         }
7291
7292         *p++ = ':';
7293         Copy(RExC_precomp, p, plen, char);
7294         assert ((RX_WRAPPED(rx) - p) < 16);
7295         r->pre_prefix = p - RX_WRAPPED(rx);
7296         p += plen;
7297         if (has_runon)
7298             *p++ = '\n';
7299         *p++ = ')';
7300         *p = 0;
7301         SvCUR_set(rx, p - RX_WRAPPED(rx));
7302     }
7303
7304     r->intflags = 0;
7305     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7306
7307     /* Useful during FAIL. */
7308 #ifdef RE_TRACK_PATTERN_OFFSETS
7309     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7310     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7311                           "%s %" UVuf " bytes for offset annotations.\n",
7312                           ri->u.offsets ? "Got" : "Couldn't get",
7313                           (UV)((2*RExC_size+1) * sizeof(U32))));
7314 #endif
7315     SetProgLen(ri,RExC_size);
7316     RExC_rx_sv = rx;
7317     RExC_rx = r;
7318     RExC_rxi = ri;
7319
7320     /* Second pass: emit code. */
7321     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7322     RExC_pm_flags = pm_flags;
7323     RExC_parse = exp;
7324     RExC_end = exp + plen;
7325     RExC_naughty = 0;
7326     RExC_emit_start = ri->program;
7327     RExC_emit = ri->program;
7328     RExC_emit_bound = ri->program + RExC_size + 1;
7329     pRExC_state->code_index = 0;
7330
7331     *((char*) RExC_emit++) = (char) REG_MAGIC;
7332     /* setup various meta data about recursion, this all requires
7333      * RExC_npar to be correctly set, and a bit later on we clear it */
7334     if (RExC_seen & REG_RECURSE_SEEN) {
7335         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7336             "%*s%*s Setting up open/close parens\n",
7337                   22, "|    |", (int)(0 * 2 + 1), ""));
7338
7339         /* setup RExC_open_parens, which holds the address of each
7340          * OPEN tag, and to make things simpler for the 0 index
7341          * the start of the program - this is used later for offsets */
7342         Newxz(RExC_open_parens, RExC_npar,regnode *);
7343         SAVEFREEPV(RExC_open_parens);
7344         RExC_open_parens[0] = RExC_emit;
7345
7346         /* setup RExC_close_parens, which holds the address of each
7347          * CLOSE tag, and to make things simpler for the 0 index
7348          * the end of the program - this is used later for offsets */
7349         Newxz(RExC_close_parens, RExC_npar,regnode *);
7350         SAVEFREEPV(RExC_close_parens);
7351         /* we dont know where end op starts yet, so we dont
7352          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7353
7354         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7355          * So its 1 if there are no parens. */
7356         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7357                                          ((RExC_npar & 0x07) != 0);
7358         Newx(RExC_study_chunk_recursed,
7359              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7360         SAVEFREEPV(RExC_study_chunk_recursed);
7361     }
7362     RExC_npar = 1;
7363     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7364         ReREFCNT_dec(rx);
7365         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#" UVxf, (UV) flags);
7366     }
7367     DEBUG_OPTIMISE_r(
7368         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7369     );
7370
7371     /* XXXX To minimize changes to RE engine we always allocate
7372        3-units-long substrs field. */
7373     Newx(r->substrs, 1, struct reg_substr_data);
7374     if (RExC_recurse_count) {
7375         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
7376         SAVEFREEPV(RExC_recurse);
7377     }
7378
7379   reStudy:
7380     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7381     DEBUG_r(
7382         RExC_study_chunk_recursed_count= 0;
7383     );
7384     Zero(r->substrs, 1, struct reg_substr_data);
7385     if (RExC_study_chunk_recursed) {
7386         Zero(RExC_study_chunk_recursed,
7387              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7388     }
7389
7390
7391 #ifdef TRIE_STUDY_OPT
7392     if (!restudied) {
7393         StructCopy(&zero_scan_data, &data, scan_data_t);
7394         copyRExC_state = RExC_state;
7395     } else {
7396         U32 seen=RExC_seen;
7397         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7398
7399         RExC_state = copyRExC_state;
7400         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7401             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7402         else
7403             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7404         StructCopy(&zero_scan_data, &data, scan_data_t);
7405     }
7406 #else
7407     StructCopy(&zero_scan_data, &data, scan_data_t);
7408 #endif
7409
7410     /* Dig out information for optimizations. */
7411     r->extflags = RExC_flags; /* was pm_op */
7412     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7413
7414     if (UTF)
7415         SvUTF8_on(rx);  /* Unicode in it? */
7416     ri->regstclass = NULL;
7417     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7418         r->intflags |= PREGf_NAUGHTY;
7419     scan = ri->program + 1;             /* First BRANCH. */
7420
7421     /* testing for BRANCH here tells us whether there is "must appear"
7422        data in the pattern. If there is then we can use it for optimisations */
7423     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7424                                                   */
7425         SSize_t fake;
7426         STRLEN longest_length[2];
7427         regnode_ssc ch_class; /* pointed to by data */
7428         int stclass_flag;
7429         SSize_t last_close = 0; /* pointed to by data */
7430         regnode *first= scan;
7431         regnode *first_next= regnext(first);
7432         int i;
7433
7434         /*
7435          * Skip introductions and multiplicators >= 1
7436          * so that we can extract the 'meat' of the pattern that must
7437          * match in the large if() sequence following.
7438          * NOTE that EXACT is NOT covered here, as it is normally
7439          * picked up by the optimiser separately.
7440          *
7441          * This is unfortunate as the optimiser isnt handling lookahead
7442          * properly currently.
7443          *
7444          */
7445         while ((OP(first) == OPEN && (sawopen = 1)) ||
7446                /* An OR of *one* alternative - should not happen now. */
7447             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7448             /* for now we can't handle lookbehind IFMATCH*/
7449             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7450             (OP(first) == PLUS) ||
7451             (OP(first) == MINMOD) ||
7452                /* An {n,m} with n>0 */
7453             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7454             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7455         {
7456                 /*
7457                  * the only op that could be a regnode is PLUS, all the rest
7458                  * will be regnode_1 or regnode_2.
7459                  *
7460                  * (yves doesn't think this is true)
7461                  */
7462                 if (OP(first) == PLUS)
7463                     sawplus = 1;
7464                 else {
7465                     if (OP(first) == MINMOD)
7466                         sawminmod = 1;
7467                     first += regarglen[OP(first)];
7468                 }
7469                 first = NEXTOPER(first);
7470                 first_next= regnext(first);
7471         }
7472
7473         /* Starting-point info. */
7474       again:
7475         DEBUG_PEEP("first:", first, 0, 0);
7476         /* Ignore EXACT as we deal with it later. */
7477         if (PL_regkind[OP(first)] == EXACT) {
7478             if (OP(first) == EXACT || OP(first) == EXACTL)
7479                 NOOP;   /* Empty, get anchored substr later. */
7480             else
7481                 ri->regstclass = first;
7482         }
7483 #ifdef TRIE_STCLASS
7484         else if (PL_regkind[OP(first)] == TRIE &&
7485                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7486         {
7487             /* this can happen only on restudy */
7488             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7489         }
7490 #endif
7491         else if (REGNODE_SIMPLE(OP(first)))
7492             ri->regstclass = first;
7493         else if (PL_regkind[OP(first)] == BOUND ||
7494                  PL_regkind[OP(first)] == NBOUND)
7495             ri->regstclass = first;
7496         else if (PL_regkind[OP(first)] == BOL) {
7497             r->intflags |= (OP(first) == MBOL
7498                            ? PREGf_ANCH_MBOL
7499                            : PREGf_ANCH_SBOL);
7500             first = NEXTOPER(first);
7501             goto again;
7502         }
7503         else if (OP(first) == GPOS) {
7504             r->intflags |= PREGf_ANCH_GPOS;
7505             first = NEXTOPER(first);
7506             goto again;
7507         }
7508         else if ((!sawopen || !RExC_sawback) &&
7509             !sawlookahead &&
7510             (OP(first) == STAR &&
7511             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7512             !(r->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
7513         {
7514             /* turn .* into ^.* with an implied $*=1 */
7515             const int type =
7516                 (OP(NEXTOPER(first)) == REG_ANY)
7517                     ? PREGf_ANCH_MBOL
7518                     : PREGf_ANCH_SBOL;
7519             r->intflags |= (type | PREGf_IMPLICIT);
7520             first = NEXTOPER(first);
7521             goto again;
7522         }
7523         if (sawplus && !sawminmod && !sawlookahead
7524             && (!sawopen || !RExC_sawback)
7525             && !pRExC_state->code_blocks) /* May examine pos and $& */
7526             /* x+ must match at the 1st pos of run of x's */
7527             r->intflags |= PREGf_SKIP;
7528
7529         /* Scan is after the zeroth branch, first is atomic matcher. */
7530 #ifdef TRIE_STUDY_OPT
7531         DEBUG_PARSE_r(
7532             if (!restudied)
7533                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7534                               (IV)(first - scan + 1))
7535         );
7536 #else
7537         DEBUG_PARSE_r(
7538             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7539                 (IV)(first - scan + 1))
7540         );
7541 #endif
7542
7543
7544         /*
7545         * If there's something expensive in the r.e., find the
7546         * longest literal string that must appear and make it the
7547         * regmust.  Resolve ties in favor of later strings, since
7548         * the regstart check works with the beginning of the r.e.
7549         * and avoiding duplication strengthens checking.  Not a
7550         * strong reason, but sufficient in the absence of others.
7551         * [Now we resolve ties in favor of the earlier string if
7552         * it happens that c_offset_min has been invalidated, since the
7553         * earlier string may buy us something the later one won't.]
7554         */
7555
7556         data.substrs[0].str = newSVpvs("");
7557         data.substrs[1].str = newSVpvs("");
7558         data.last_found = newSVpvs("");
7559         data.cur_is_floating = 0; /* initially any found substring is fixed */
7560         ENTER_with_name("study_chunk");
7561         SAVEFREESV(data.substrs[0].str);
7562         SAVEFREESV(data.substrs[1].str);
7563         SAVEFREESV(data.last_found);
7564         first = scan;
7565         if (!ri->regstclass) {
7566             ssc_init(pRExC_state, &ch_class);
7567             data.start_class = &ch_class;
7568             stclass_flag = SCF_DO_STCLASS_AND;
7569         } else                          /* XXXX Check for BOUND? */
7570             stclass_flag = 0;
7571         data.last_closep = &last_close;
7572
7573         DEBUG_RExC_seen();
7574         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7575                              scan + RExC_size, /* Up to end */
7576             &data, -1, 0, NULL,
7577             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7578                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7579             0);
7580
7581
7582         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7583
7584
7585         if ( RExC_npar == 1 && !data.cur_is_floating
7586              && data.last_start_min == 0 && data.last_end > 0
7587              && !RExC_seen_zerolen
7588              && !(RExC_seen & REG_VERBARG_SEEN)
7589              && !(RExC_seen & REG_GPOS_SEEN)
7590         ){
7591             r->extflags |= RXf_CHECK_ALL;
7592         }
7593         scan_commit(pRExC_state, &data,&minlen,0);
7594
7595
7596         /* XXX this is done in reverse order because that's the way the
7597          * code was before it was parameterised. Don't know whether it
7598          * actually needs doing in reverse order. DAPM */
7599         for (i = 1; i >= 0; i--) {
7600             longest_length[i] = CHR_SVLEN(data.substrs[i].str);
7601
7602             if (   !(   i
7603                      && SvCUR(data.substrs[0].str)  /* ok to leave SvCUR */
7604                      &&    data.substrs[0].min_offset
7605                         == data.substrs[1].min_offset
7606                      &&    SvCUR(data.substrs[0].str)
7607                         == SvCUR(data.substrs[1].str)
7608                     )
7609                 && S_setup_longest (aTHX_ pRExC_state,
7610                                         &(r->substrs->data[i]),
7611                                         &(data.substrs[i]),
7612                                         longest_length[i]))
7613             {
7614                 r->substrs->data[i].min_offset =
7615                         data.substrs[i].min_offset - data.substrs[i].lookbehind;
7616
7617                 r->substrs->data[i].max_offset = data.substrs[i].max_offset;
7618                 /* Don't offset infinity */
7619                 if (data.substrs[i].max_offset < SSize_t_MAX)
7620                     r->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
7621                 SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
7622             }
7623             else {
7624                 r->substrs->data[i].substr      = NULL;
7625                 r->substrs->data[i].utf8_substr = NULL;
7626                 longest_length[i] = 0;
7627             }
7628         }
7629
7630         LEAVE_with_name("study_chunk");
7631
7632         if (ri->regstclass
7633             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7634             ri->regstclass = NULL;
7635
7636         if ((!(r->substrs->data[0].substr || r->substrs->data[0].utf8_substr)
7637               || r->substrs->data[0].min_offset)
7638             && stclass_flag
7639             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7640             && is_ssc_worth_it(pRExC_state, data.start_class))
7641         {
7642             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7643
7644             ssc_finalize(pRExC_state, data.start_class);
7645
7646             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7647             StructCopy(data.start_class,
7648                        (regnode_ssc*)RExC_rxi->data->data[n],
7649                        regnode_ssc);
7650             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7651             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7652             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7653                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7654                       Perl_re_printf( aTHX_
7655                                     "synthetic stclass \"%s\".\n",
7656                                     SvPVX_const(sv));});
7657             data.start_class = NULL;
7658         }
7659
7660         /* A temporary algorithm prefers floated substr to fixed one of
7661          * same length to dig more info. */
7662         i = (longest_length[0] <= longest_length[1]);
7663         r->substrs->check_ix = i;
7664         r->check_end_shift  = r->substrs->data[i].end_shift;
7665         r->check_substr     = r->substrs->data[i].substr;
7666         r->check_utf8       = r->substrs->data[i].utf8_substr;
7667         r->check_offset_min = r->substrs->data[i].min_offset;
7668         r->check_offset_max = r->substrs->data[i].max_offset;
7669         if (!i && (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
7670             r->intflags |= PREGf_NOSCAN;
7671
7672         if ((r->check_substr || r->check_utf8) ) {
7673             r->extflags |= RXf_USE_INTUIT;
7674             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7675                 r->extflags |= RXf_INTUIT_TAIL;
7676         }
7677
7678         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7679         if ( (STRLEN)minlen < longest_length[1] )
7680             minlen= longest_length[1];
7681         if ( (STRLEN)minlen < longest_length[0] )
7682             minlen= longest_length[0];
7683         */
7684     }
7685     else {
7686         /* Several toplevels. Best we can is to set minlen. */
7687         SSize_t fake;
7688         regnode_ssc ch_class;
7689         SSize_t last_close = 0;
7690
7691         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7692
7693         scan = ri->program + 1;
7694         ssc_init(pRExC_state, &ch_class);
7695         data.start_class = &ch_class;
7696         data.last_closep = &last_close;
7697
7698         DEBUG_RExC_seen();
7699         minlen = study_chunk(pRExC_state,
7700             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7701             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7702                                                       ? SCF_TRIE_DOING_RESTUDY
7703                                                       : 0),
7704             0);
7705
7706         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7707
7708         r->check_substr = NULL;
7709         r->check_utf8 = NULL;
7710         r->substrs->data[0].substr      = NULL;
7711         r->substrs->data[0].utf8_substr = NULL;
7712         r->substrs->data[1].substr      = NULL;
7713         r->substrs->data[1].utf8_substr = NULL;
7714
7715         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7716             && is_ssc_worth_it(pRExC_state, data.start_class))
7717         {
7718             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7719
7720             ssc_finalize(pRExC_state, data.start_class);
7721
7722             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7723             StructCopy(data.start_class,
7724                        (regnode_ssc*)RExC_rxi->data->data[n],
7725                        regnode_ssc);
7726             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7727             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7728             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7729                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7730                       Perl_re_printf( aTHX_
7731                                     "synthetic stclass \"%s\".\n",
7732                                     SvPVX_const(sv));});
7733             data.start_class = NULL;
7734         }
7735     }
7736
7737     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7738         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7739         r->maxlen = REG_INFTY;
7740     }
7741     else {
7742         r->maxlen = RExC_maxlen;
7743     }
7744
7745     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7746        the "real" pattern. */
7747     DEBUG_OPTIMISE_r({
7748         Perl_re_printf( aTHX_ "minlen: %" IVdf " r->minlen:%" IVdf " maxlen:%" IVdf "\n",
7749                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7750     });
7751     r->minlenret = minlen;
7752     if (r->minlen < minlen)
7753         r->minlen = minlen;
7754
7755     if (RExC_seen & REG_RECURSE_SEEN ) {
7756         r->intflags |= PREGf_RECURSE_SEEN;
7757         Newxz(r->recurse_locinput, r->nparens + 1, char *);
7758     }
7759     if (RExC_seen & REG_GPOS_SEEN)
7760         r->intflags |= PREGf_GPOS_SEEN;
7761     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7762         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7763                                                 lookbehind */
7764     if (pRExC_state->code_blocks)
7765         r->extflags |= RXf_EVAL_SEEN;
7766     if (RExC_seen & REG_VERBARG_SEEN)
7767     {
7768         r->intflags |= PREGf_VERBARG_SEEN;
7769         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7770     }
7771     if (RExC_seen & REG_CUTGROUP_SEEN)
7772         r->intflags |= PREGf_CUTGROUP_SEEN;
7773     if (pm_flags & PMf_USE_RE_EVAL)
7774         r->intflags |= PREGf_USE_RE_EVAL;
7775     if (RExC_paren_names)
7776         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7777     else
7778         RXp_PAREN_NAMES(r) = NULL;
7779
7780     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7781      * so it can be used in pp.c */
7782     if (r->intflags & PREGf_ANCH)
7783         r->extflags |= RXf_IS_ANCHORED;
7784
7785
7786     {
7787         /* this is used to identify "special" patterns that might result
7788          * in Perl NOT calling the regex engine and instead doing the match "itself",
7789          * particularly special cases in split//. By having the regex compiler
7790          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7791          * we avoid weird issues with equivalent patterns resulting in different behavior,
7792          * AND we allow non Perl engines to get the same optimizations by the setting the
7793          * flags appropriately - Yves */
7794         regnode *first = ri->program + 1;
7795         U8 fop = OP(first);
7796         regnode *next = regnext(first);
7797         U8 nop = OP(next);
7798
7799         if (PL_regkind[fop] == NOTHING && nop == END)
7800             r->extflags |= RXf_NULL;
7801         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7802             /* when fop is SBOL first->flags will be true only when it was
7803              * produced by parsing /\A/, and not when parsing /^/. This is
7804              * very important for the split code as there we want to
7805              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7806              * See rt #122761 for more details. -- Yves */
7807             r->extflags |= RXf_START_ONLY;
7808         else if (fop == PLUS
7809                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7810                  && nop == END)
7811             r->extflags |= RXf_WHITE;
7812         else if ( r->extflags & RXf_SPLIT
7813                   && (fop == EXACT || fop == EXACTL)
7814                   && STR_LEN(first) == 1
7815                   && *(STRING(first)) == ' '
7816                   && nop == END )
7817             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7818
7819     }
7820
7821     if (RExC_contains_locale) {
7822         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7823     }
7824
7825 #ifdef DEBUGGING
7826     if (RExC_paren_names) {
7827         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7828         ri->data->data[ri->name_list_idx]
7829                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7830     } else
7831 #endif
7832     ri->name_list_idx = 0;
7833
7834     while ( RExC_recurse_count > 0 ) {
7835         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7836         /*
7837          * This data structure is set up in study_chunk() and is used
7838          * to calculate the distance between a GOSUB regopcode and
7839          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
7840          * it refers to.
7841          *
7842          * If for some reason someone writes code that optimises
7843          * away a GOSUB opcode then the assert should be changed to
7844          * an if(scan) to guard the ARG2L_SET() - Yves
7845          *
7846          */
7847         assert(scan && OP(scan) == GOSUB);
7848         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7849     }
7850
7851     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7852     /* assume we don't need to swap parens around before we match */
7853     DEBUG_TEST_r({
7854         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7855             (unsigned long)RExC_study_chunk_recursed_count);
7856     });
7857     DEBUG_DUMP_r({
7858         DEBUG_RExC_seen();
7859         Perl_re_printf( aTHX_ "Final program:\n");
7860         regdump(r);
7861     });
7862 #ifdef RE_TRACK_PATTERN_OFFSETS
7863     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7864         const STRLEN len = ri->u.offsets[0];
7865         STRLEN i;
7866         GET_RE_DEBUG_FLAGS_DECL;
7867         Perl_re_printf( aTHX_
7868                       "Offsets: [%" UVuf "]\n\t", (UV)ri->u.offsets[0]);
7869         for (i = 1; i <= len; i++) {
7870             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7871                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7872                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7873             }
7874         Perl_re_printf( aTHX_  "\n");
7875     });
7876 #endif
7877
7878 #ifdef USE_ITHREADS
7879     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7880      * by setting the regexp SV to readonly-only instead. If the
7881      * pattern's been recompiled, the USEDness should remain. */
7882     if (old_re && SvREADONLY(old_re))
7883         SvREADONLY_on(rx);
7884 #endif
7885     return rx;
7886 }
7887
7888
7889 SV*
7890 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7891                     const U32 flags)
7892 {
7893     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7894
7895     PERL_UNUSED_ARG(value);
7896
7897     if (flags & RXapif_FETCH) {
7898         return reg_named_buff_fetch(rx, key, flags);
7899     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7900         Perl_croak_no_modify();
7901         return NULL;
7902     } else if (flags & RXapif_EXISTS) {
7903         return reg_named_buff_exists(rx, key, flags)
7904             ? &PL_sv_yes
7905             : &PL_sv_no;
7906     } else if (flags & RXapif_REGNAMES) {
7907         return reg_named_buff_all(rx, flags);
7908     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7909         return reg_named_buff_scalar(rx, flags);
7910     } else {
7911         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7912         return NULL;
7913     }
7914 }
7915
7916 SV*
7917 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7918                          const U32 flags)
7919 {
7920     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7921     PERL_UNUSED_ARG(lastkey);
7922
7923     if (flags & RXapif_FIRSTKEY)
7924         return reg_named_buff_firstkey(rx, flags);
7925     else if (flags & RXapif_NEXTKEY)
7926         return reg_named_buff_nextkey(rx, flags);
7927     else {
7928         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7929                                             (int)flags);
7930         return NULL;
7931     }
7932 }
7933
7934 SV*
7935 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7936                           const U32 flags)
7937 {
7938     SV *ret;
7939     struct regexp *const rx = ReANY(r);
7940
7941     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7942
7943     if (rx && RXp_PAREN_NAMES(rx)) {
7944         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7945         if (he_str) {
7946             IV i;
7947             SV* sv_dat=HeVAL(he_str);
7948             I32 *nums=(I32*)SvPVX(sv_dat);
7949             AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
7950             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7951                 if ((I32)(rx->nparens) >= nums[i]
7952                     && rx->offs[nums[i]].start != -1
7953                     && rx->offs[nums[i]].end != -1)
7954                 {
7955                     ret = newSVpvs("");
7956                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7957                     if (!retarray)
7958                         return ret;
7959                 } else {
7960                     if (retarray)
7961                         ret = newSVsv(&PL_sv_undef);
7962                 }
7963                 if (retarray)
7964                     av_push(retarray, ret);
7965             }
7966             if (retarray)
7967                 return newRV_noinc(MUTABLE_SV(retarray));
7968         }
7969     }
7970     return NULL;
7971 }
7972
7973 bool
7974 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7975                            const U32 flags)
7976 {
7977     struct regexp *const rx = ReANY(r);
7978
7979     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7980
7981     if (rx && RXp_PAREN_NAMES(rx)) {
7982         if (flags & RXapif_ALL) {
7983             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7984         } else {
7985             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7986             if (sv) {
7987                 SvREFCNT_dec_NN(sv);
7988                 return TRUE;
7989             } else {
7990                 return FALSE;
7991             }
7992         }
7993     } else {
7994         return FALSE;
7995     }
7996 }
7997
7998 SV*
7999 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
8000 {
8001     struct regexp *const rx = ReANY(r);
8002
8003     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
8004
8005     if ( rx && RXp_PAREN_NAMES(rx) ) {
8006         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
8007
8008         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
8009     } else {
8010         return FALSE;
8011     }
8012 }
8013
8014 SV*
8015 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
8016 {
8017     struct regexp *const rx = ReANY(r);
8018     GET_RE_DEBUG_FLAGS_DECL;
8019
8020     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
8021
8022     if (rx && RXp_PAREN_NAMES(rx)) {
8023         HV *hv = RXp_PAREN_NAMES(rx);
8024         HE *temphe;
8025         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8026             IV i;
8027             IV parno = 0;
8028             SV* sv_dat = HeVAL(temphe);
8029             I32 *nums = (I32*)SvPVX(sv_dat);
8030             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8031                 if ((I32)(rx->lastparen) >= nums[i] &&
8032                     rx->offs[nums[i]].start != -1 &&
8033                     rx->offs[nums[i]].end != -1)
8034                 {
8035                     parno = nums[i];
8036                     break;
8037                 }
8038             }
8039             if (parno || flags & RXapif_ALL) {
8040                 return newSVhek(HeKEY_hek(temphe));
8041             }
8042         }
8043     }
8044     return NULL;
8045 }
8046
8047 SV*
8048 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8049 {
8050     SV *ret;
8051     AV *av;
8052     SSize_t length;
8053     struct regexp *const rx = ReANY(r);
8054
8055     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8056
8057     if (rx && RXp_PAREN_NAMES(rx)) {
8058         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8059             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8060         } else if (flags & RXapif_ONE) {
8061             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8062             av = MUTABLE_AV(SvRV(ret));
8063             length = av_tindex(av);
8064             SvREFCNT_dec_NN(ret);
8065             return newSViv(length + 1);
8066         } else {
8067             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8068                                                 (int)flags);
8069             return NULL;
8070         }
8071     }
8072     return &PL_sv_undef;
8073 }
8074
8075 SV*
8076 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8077 {
8078     struct regexp *const rx = ReANY(r);
8079     AV *av = newAV();
8080
8081     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8082
8083     if (rx && RXp_PAREN_NAMES(rx)) {
8084         HV *hv= RXp_PAREN_NAMES(rx);
8085         HE *temphe;
8086         (void)hv_iterinit(hv);
8087         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8088             IV i;
8089             IV parno = 0;
8090             SV* sv_dat = HeVAL(temphe);
8091             I32 *nums = (I32*)SvPVX(sv_dat);
8092             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8093                 if ((I32)(rx->lastparen) >= nums[i] &&
8094                     rx->offs[nums[i]].start != -1 &&
8095                     rx->offs[nums[i]].end != -1)
8096                 {
8097                     parno = nums[i];
8098                     break;
8099                 }
8100             }
8101             if (parno || flags & RXapif_ALL) {
8102                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8103             }
8104         }
8105     }
8106
8107     return newRV_noinc(MUTABLE_SV(av));
8108 }
8109
8110 void
8111 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8112                              SV * const sv)
8113 {
8114     struct regexp *const rx = ReANY(r);
8115     char *s = NULL;
8116     SSize_t i = 0;
8117     SSize_t s1, t1;
8118     I32 n = paren;
8119
8120     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8121
8122     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8123            || n == RX_BUFF_IDX_CARET_FULLMATCH
8124            || n == RX_BUFF_IDX_CARET_POSTMATCH
8125        )
8126     {
8127         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8128         if (!keepcopy) {
8129             /* on something like
8130              *    $r = qr/.../;
8131              *    /$qr/p;
8132              * the KEEPCOPY is set on the PMOP rather than the regex */
8133             if (PL_curpm && r == PM_GETRE(PL_curpm))
8134                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8135         }
8136         if (!keepcopy)
8137             goto ret_undef;
8138     }
8139
8140     if (!rx->subbeg)
8141         goto ret_undef;
8142
8143     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8144         /* no need to distinguish between them any more */
8145         n = RX_BUFF_IDX_FULLMATCH;
8146
8147     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8148         && rx->offs[0].start != -1)
8149     {
8150         /* $`, ${^PREMATCH} */
8151         i = rx->offs[0].start;
8152         s = rx->subbeg;
8153     }
8154     else
8155     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8156         && rx->offs[0].end != -1)
8157     {
8158         /* $', ${^POSTMATCH} */
8159         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8160         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8161     }
8162     else
8163     if ( 0 <= n && n <= (I32)rx->nparens &&
8164         (s1 = rx->offs[n].start) != -1 &&
8165         (t1 = rx->offs[n].end) != -1)
8166     {
8167         /* $&, ${^MATCH},  $1 ... */
8168         i = t1 - s1;
8169         s = rx->subbeg + s1 - rx->suboffset;
8170     } else {
8171         goto ret_undef;
8172     }
8173
8174     assert(s >= rx->subbeg);
8175     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8176     if (i >= 0) {
8177 #ifdef NO_TAINT_SUPPORT
8178         sv_setpvn(sv, s, i);
8179 #else
8180         const int oldtainted = TAINT_get;
8181         TAINT_NOT;
8182         sv_setpvn(sv, s, i);
8183         TAINT_set(oldtainted);
8184 #endif
8185         if (RXp_MATCH_UTF8(rx))
8186             SvUTF8_on(sv);
8187         else
8188             SvUTF8_off(sv);
8189         if (TAINTING_get) {
8190             if (RXp_MATCH_TAINTED(rx)) {
8191                 if (SvTYPE(sv) >= SVt_PVMG) {
8192                     MAGIC* const mg = SvMAGIC(sv);
8193                     MAGIC* mgt;
8194                     TAINT;
8195                     SvMAGIC_set(sv, mg->mg_moremagic);
8196                     SvTAINT(sv);
8197                     if ((mgt = SvMAGIC(sv))) {
8198                         mg->mg_moremagic = mgt;
8199                         SvMAGIC_set(sv, mg);
8200                     }
8201                 } else {
8202                     TAINT;
8203                     SvTAINT(sv);
8204                 }
8205             } else
8206                 SvTAINTED_off(sv);
8207         }
8208     } else {
8209       ret_undef:
8210         sv_set_undef(sv);
8211         return;
8212     }
8213 }
8214
8215 void
8216 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8217                                                          SV const * const value)
8218 {
8219     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8220
8221     PERL_UNUSED_ARG(rx);
8222     PERL_UNUSED_ARG(paren);
8223     PERL_UNUSED_ARG(value);
8224
8225     if (!PL_localizing)
8226         Perl_croak_no_modify();
8227 }
8228
8229 I32
8230 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8231                               const I32 paren)
8232 {
8233     struct regexp *const rx = ReANY(r);
8234     I32 i;
8235     I32 s1, t1;
8236
8237     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8238
8239     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8240         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8241         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8242     )
8243     {
8244         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8245         if (!keepcopy) {
8246             /* on something like
8247              *    $r = qr/.../;
8248              *    /$qr/p;
8249              * the KEEPCOPY is set on the PMOP rather than the regex */
8250             if (PL_curpm && r == PM_GETRE(PL_curpm))
8251                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8252         }
8253         if (!keepcopy)
8254             goto warn_undef;
8255     }
8256
8257     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8258     switch (paren) {
8259       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8260       case RX_BUFF_IDX_PREMATCH:       /* $` */
8261         if (rx->offs[0].start != -1) {
8262                         i = rx->offs[0].start;
8263                         if (i > 0) {
8264                                 s1 = 0;
8265                                 t1 = i;
8266                                 goto getlen;
8267                         }
8268             }
8269         return 0;
8270
8271       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8272       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8273             if (rx->offs[0].end != -1) {
8274                         i = rx->sublen - rx->offs[0].end;
8275                         if (i > 0) {
8276                                 s1 = rx->offs[0].end;
8277                                 t1 = rx->sublen;
8278                                 goto getlen;
8279                         }
8280             }
8281         return 0;
8282
8283       default: /* $& / ${^MATCH}, $1, $2, ... */
8284             if (paren <= (I32)rx->nparens &&
8285             (s1 = rx->offs[paren].start) != -1 &&
8286             (t1 = rx->offs[paren].end) != -1)
8287             {
8288             i = t1 - s1;
8289             goto getlen;
8290         } else {
8291           warn_undef:
8292             if (ckWARN(WARN_UNINITIALIZED))
8293                 report_uninit((const SV *)sv);
8294             return 0;
8295         }
8296     }
8297   getlen:
8298     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8299         const char * const s = rx->subbeg - rx->suboffset + s1;
8300         const U8 *ep;
8301         STRLEN el;
8302
8303         i = t1 - s1;
8304         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8305                         i = el;
8306     }
8307     return i;
8308 }
8309
8310 SV*
8311 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8312 {
8313     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8314         PERL_UNUSED_ARG(rx);
8315         if (0)
8316             return NULL;
8317         else
8318             return newSVpvs("Regexp");
8319 }
8320
8321 /* Scans the name of a named buffer from the pattern.
8322  * If flags is REG_RSN_RETURN_NULL returns null.
8323  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8324  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8325  * to the parsed name as looked up in the RExC_paren_names hash.
8326  * If there is an error throws a vFAIL().. type exception.
8327  */
8328
8329 #define REG_RSN_RETURN_NULL    0
8330 #define REG_RSN_RETURN_NAME    1
8331 #define REG_RSN_RETURN_DATA    2
8332
8333 STATIC SV*
8334 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8335 {
8336     char *name_start = RExC_parse;
8337
8338     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8339
8340     assert (RExC_parse <= RExC_end);
8341     if (RExC_parse == RExC_end) NOOP;
8342     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8343          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8344           * using do...while */
8345         if (UTF)
8346             do {
8347                 RExC_parse += UTF8SKIP(RExC_parse);
8348             } while (   RExC_parse < RExC_end
8349                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8350         else
8351             do {
8352                 RExC_parse++;
8353             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8354     } else {
8355         RExC_parse++; /* so the <- from the vFAIL is after the offending
8356                          character */
8357         vFAIL("Group name must start with a non-digit word character");
8358     }
8359     if ( flags ) {
8360         SV* sv_name
8361             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8362                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8363         if ( flags == REG_RSN_RETURN_NAME)
8364             return sv_name;
8365         else if (flags==REG_RSN_RETURN_DATA) {
8366             HE *he_str = NULL;
8367             SV *sv_dat = NULL;
8368             if ( ! sv_name )      /* should not happen*/
8369                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8370             if (RExC_paren_names)
8371                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8372             if ( he_str )
8373                 sv_dat = HeVAL(he_str);
8374             if ( ! sv_dat )
8375                 vFAIL("Reference to nonexistent named group");
8376             return sv_dat;
8377         }
8378         else {
8379             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8380                        (unsigned long) flags);
8381         }
8382         NOT_REACHED; /* NOTREACHED */
8383     }
8384     return NULL;
8385 }
8386
8387 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8388     int num;                                                    \
8389     if (RExC_lastparse!=RExC_parse) {                           \
8390         Perl_re_printf( aTHX_  "%s",                                        \
8391             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8392                 RExC_end - RExC_parse, 16,                      \
8393                 "", "",                                         \
8394                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8395                 PERL_PV_PRETTY_ELLIPSES   |                     \
8396                 PERL_PV_PRETTY_LTGT       |                     \
8397                 PERL_PV_ESCAPE_RE         |                     \
8398                 PERL_PV_PRETTY_EXACTSIZE                        \
8399             )                                                   \
8400         );                                                      \
8401     } else                                                      \
8402         Perl_re_printf( aTHX_ "%16s","");                                   \
8403                                                                 \
8404     if (SIZE_ONLY)                                              \
8405        num = RExC_size + 1;                                     \
8406     else                                                        \
8407        num=REG_NODE_NUM(RExC_emit);                             \
8408     if (RExC_lastnum!=num)                                      \
8409        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8410     else                                                        \
8411        Perl_re_printf( aTHX_ "|%4s","");                                    \
8412     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8413         (int)((depth*2)), "",                                   \
8414         (funcname)                                              \
8415     );                                                          \
8416     RExC_lastnum=num;                                           \
8417     RExC_lastparse=RExC_parse;                                  \
8418 })
8419
8420
8421
8422 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8423     DEBUG_PARSE_MSG((funcname));                            \
8424     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8425 })
8426 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8427     DEBUG_PARSE_MSG((funcname));                            \
8428     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8429 })
8430
8431 /* This section of code defines the inversion list object and its methods.  The
8432  * interfaces are highly subject to change, so as much as possible is static to
8433  * this file.  An inversion list is here implemented as a malloc'd C UV array
8434  * as an SVt_INVLIST scalar.
8435  *
8436  * An inversion list for Unicode is an array of code points, sorted by ordinal
8437  * number.  Each element gives the code point that begins a range that extends
8438  * up-to but not including the code point given by the next element.  The final
8439  * element gives the first code point of a range that extends to the platform's
8440  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8441  * ...) give ranges whose code points are all in the inversion list.  We say
8442  * that those ranges are in the set.  The odd-numbered elements give ranges
8443  * whose code points are not in the inversion list, and hence not in the set.
8444  * Thus, element [0] is the first code point in the list.  Element [1]
8445  * is the first code point beyond that not in the list; and element [2] is the
8446  * first code point beyond that that is in the list.  In other words, the first
8447  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8448  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8449  * all code points in that range are not in the inversion list.  The third
8450  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8451  * list, and so forth.  Thus every element whose index is divisible by two
8452  * gives the beginning of a range that is in the list, and every element whose
8453  * index is not divisible by two gives the beginning of a range not in the
8454  * list.  If the final element's index is divisible by two, the inversion list
8455  * extends to the platform's infinity; otherwise the highest code point in the
8456  * inversion list is the contents of that element minus 1.
8457  *
8458  * A range that contains just a single code point N will look like
8459  *  invlist[i]   == N
8460  *  invlist[i+1] == N+1
8461  *
8462  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8463  * impossible to represent, so element [i+1] is omitted.  The single element
8464  * inversion list
8465  *  invlist[0] == UV_MAX
8466  * contains just UV_MAX, but is interpreted as matching to infinity.
8467  *
8468  * Taking the complement (inverting) an inversion list is quite simple, if the
8469  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8470  * This implementation reserves an element at the beginning of each inversion
8471  * list to always contain 0; there is an additional flag in the header which
8472  * indicates if the list begins at the 0, or is offset to begin at the next
8473  * element.  This means that the inversion list can be inverted without any
8474  * copying; just flip the flag.
8475  *
8476  * More about inversion lists can be found in "Unicode Demystified"
8477  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8478  *
8479  * The inversion list data structure is currently implemented as an SV pointing
8480  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8481  * array of UV whose memory management is automatically handled by the existing
8482  * facilities for SV's.
8483  *
8484  * Some of the methods should always be private to the implementation, and some
8485  * should eventually be made public */
8486
8487 /* The header definitions are in F<invlist_inline.h> */
8488
8489 #ifndef PERL_IN_XSUB_RE
8490
8491 PERL_STATIC_INLINE UV*
8492 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8493 {
8494     /* Returns a pointer to the first element in the inversion list's array.
8495      * This is called upon initialization of an inversion list.  Where the
8496      * array begins depends on whether the list has the code point U+0000 in it
8497      * or not.  The other parameter tells it whether the code that follows this
8498      * call is about to put a 0 in the inversion list or not.  The first
8499      * element is either the element reserved for 0, if TRUE, or the element
8500      * after it, if FALSE */
8501
8502     bool* offset = get_invlist_offset_addr(invlist);
8503     UV* zero_addr = (UV *) SvPVX(invlist);
8504
8505     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8506
8507     /* Must be empty */
8508     assert(! _invlist_len(invlist));
8509
8510     *zero_addr = 0;
8511
8512     /* 1^1 = 0; 1^0 = 1 */
8513     *offset = 1 ^ will_have_0;
8514     return zero_addr + *offset;
8515 }
8516
8517 #endif
8518
8519 PERL_STATIC_INLINE void
8520 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8521 {
8522     /* Sets the current number of elements stored in the inversion list.
8523      * Updates SvCUR correspondingly */
8524     PERL_UNUSED_CONTEXT;
8525     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8526
8527     assert(SvTYPE(invlist) == SVt_INVLIST);
8528
8529     SvCUR_set(invlist,
8530               (len == 0)
8531                ? 0
8532                : TO_INTERNAL_SIZE(len + offset));
8533     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8534 }
8535
8536 #ifndef PERL_IN_XSUB_RE
8537
8538 STATIC void
8539 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8540 {
8541     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
8542      * steals the list from 'src', so 'src' is made to have a NULL list.  This
8543      * is similar to what SvSetMagicSV() would do, if it were implemented on
8544      * inversion lists, though this routine avoids a copy */
8545
8546     const UV src_len          = _invlist_len(src);
8547     const bool src_offset     = *get_invlist_offset_addr(src);
8548     const STRLEN src_byte_len = SvLEN(src);
8549     char * array              = SvPVX(src);
8550
8551     const int oldtainted = TAINT_get;
8552
8553     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8554
8555     assert(SvTYPE(src) == SVt_INVLIST);
8556     assert(SvTYPE(dest) == SVt_INVLIST);
8557     assert(! invlist_is_iterating(src));
8558     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8559
8560     /* Make sure it ends in the right place with a NUL, as our inversion list
8561      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8562      * asserts it */
8563     array[src_byte_len - 1] = '\0';
8564
8565     TAINT_NOT;      /* Otherwise it breaks */
8566     sv_usepvn_flags(dest,
8567                     (char *) array,
8568                     src_byte_len - 1,
8569
8570                     /* This flag is documented to cause a copy to be avoided */
8571                     SV_HAS_TRAILING_NUL);
8572     TAINT_set(oldtainted);
8573     SvPV_set(src, 0);
8574     SvLEN_set(src, 0);
8575     SvCUR_set(src, 0);
8576
8577     /* Finish up copying over the other fields in an inversion list */
8578     *get_invlist_offset_addr(dest) = src_offset;
8579     invlist_set_len(dest, src_len, src_offset);
8580     *get_invlist_previous_index_addr(dest) = 0;
8581     invlist_iterfinish(dest);
8582 }
8583
8584 PERL_STATIC_INLINE IV*
8585 S_get_invlist_previous_index_addr(SV* invlist)
8586 {
8587     /* Return the address of the IV that is reserved to hold the cached index
8588      * */
8589     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8590
8591     assert(SvTYPE(invlist) == SVt_INVLIST);
8592
8593     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8594 }
8595
8596 PERL_STATIC_INLINE IV
8597 S_invlist_previous_index(SV* const invlist)
8598 {
8599     /* Returns cached index of previous search */
8600
8601     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8602
8603     return *get_invlist_previous_index_addr(invlist);
8604 }
8605
8606 PERL_STATIC_INLINE void
8607 S_invlist_set_previous_index(SV* const invlist, const IV index)
8608 {
8609     /* Caches <index> for later retrieval */
8610
8611     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8612
8613     assert(index == 0 || index < (int) _invlist_len(invlist));
8614
8615     *get_invlist_previous_index_addr(invlist) = index;
8616 }
8617
8618 PERL_STATIC_INLINE void
8619 S_invlist_trim(SV* invlist)
8620 {
8621     /* Free the not currently-being-used space in an inversion list */
8622
8623     /* But don't free up the space needed for the 0 UV that is always at the
8624      * beginning of the list, nor the trailing NUL */
8625     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8626
8627     PERL_ARGS_ASSERT_INVLIST_TRIM;
8628
8629     assert(SvTYPE(invlist) == SVt_INVLIST);
8630
8631     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8632 }
8633
8634 PERL_STATIC_INLINE void
8635 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8636 {
8637     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8638
8639     assert(SvTYPE(invlist) == SVt_INVLIST);
8640
8641     invlist_set_len(invlist, 0, 0);
8642     invlist_trim(invlist);
8643 }
8644
8645 #endif /* ifndef PERL_IN_XSUB_RE */
8646
8647 PERL_STATIC_INLINE bool
8648 S_invlist_is_iterating(SV* const invlist)
8649 {
8650     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8651
8652     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8653 }
8654
8655 #ifndef PERL_IN_XSUB_RE
8656
8657 PERL_STATIC_INLINE UV
8658 S_invlist_max(SV* const invlist)
8659 {
8660     /* Returns the maximum number of elements storable in the inversion list's
8661      * array, without having to realloc() */
8662
8663     PERL_ARGS_ASSERT_INVLIST_MAX;
8664
8665     assert(SvTYPE(invlist) == SVt_INVLIST);
8666
8667     /* Assumes worst case, in which the 0 element is not counted in the
8668      * inversion list, so subtracts 1 for that */
8669     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8670            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8671            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8672 }
8673 SV*
8674 Perl__new_invlist(pTHX_ IV initial_size)
8675 {
8676
8677     /* Return a pointer to a newly constructed inversion list, with enough
8678      * space to store 'initial_size' elements.  If that number is negative, a
8679      * system default is used instead */
8680
8681     SV* new_list;
8682
8683     if (initial_size < 0) {
8684         initial_size = 10;
8685     }
8686
8687     /* Allocate the initial space */
8688     new_list = newSV_type(SVt_INVLIST);
8689
8690     /* First 1 is in case the zero element isn't in the list; second 1 is for
8691      * trailing NUL */
8692     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8693     invlist_set_len(new_list, 0, 0);
8694
8695     /* Force iterinit() to be used to get iteration to work */
8696     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8697
8698     *get_invlist_previous_index_addr(new_list) = 0;
8699
8700     return new_list;
8701 }
8702
8703 SV*
8704 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8705 {
8706     /* Return a pointer to a newly constructed inversion list, initialized to
8707      * point to <list>, which has to be in the exact correct inversion list
8708      * form, including internal fields.  Thus this is a dangerous routine that
8709      * should not be used in the wrong hands.  The passed in 'list' contains
8710      * several header fields at the beginning that are not part of the
8711      * inversion list body proper */
8712
8713     const STRLEN length = (STRLEN) list[0];
8714     const UV version_id =          list[1];
8715     const bool offset   =    cBOOL(list[2]);
8716 #define HEADER_LENGTH 3
8717     /* If any of the above changes in any way, you must change HEADER_LENGTH
8718      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8719      *      perl -E 'say int(rand 2**31-1)'
8720      */
8721 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8722                                         data structure type, so that one being
8723                                         passed in can be validated to be an
8724                                         inversion list of the correct vintage.
8725                                        */
8726
8727     SV* invlist = newSV_type(SVt_INVLIST);
8728
8729     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8730
8731     if (version_id != INVLIST_VERSION_ID) {
8732         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8733     }
8734
8735     /* The generated array passed in includes header elements that aren't part
8736      * of the list proper, so start it just after them */
8737     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8738
8739     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8740                                shouldn't touch it */
8741
8742     *(get_invlist_offset_addr(invlist)) = offset;
8743
8744     /* The 'length' passed to us is the physical number of elements in the
8745      * inversion list.  But if there is an offset the logical number is one
8746      * less than that */
8747     invlist_set_len(invlist, length  - offset, offset);
8748
8749     invlist_set_previous_index(invlist, 0);
8750
8751     /* Initialize the iteration pointer. */
8752     invlist_iterfinish(invlist);
8753
8754     SvREADONLY_on(invlist);
8755
8756     return invlist;
8757 }
8758
8759 STATIC void
8760 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8761 {
8762     /* Grow the maximum size of an inversion list */
8763
8764     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8765
8766     assert(SvTYPE(invlist) == SVt_INVLIST);
8767
8768     /* Add one to account for the zero element at the beginning which may not
8769      * be counted by the calling parameters */
8770     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8771 }
8772
8773 STATIC void
8774 S__append_range_to_invlist(pTHX_ SV* const invlist,
8775                                  const UV start, const UV end)
8776 {
8777    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8778     * the end of the inversion list.  The range must be above any existing
8779     * ones. */
8780
8781     UV* array;
8782     UV max = invlist_max(invlist);
8783     UV len = _invlist_len(invlist);
8784     bool offset;
8785
8786     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8787
8788     if (len == 0) { /* Empty lists must be initialized */
8789         offset = start != 0;
8790         array = _invlist_array_init(invlist, ! offset);
8791     }
8792     else {
8793         /* Here, the existing list is non-empty. The current max entry in the
8794          * list is generally the first value not in the set, except when the
8795          * set extends to the end of permissible values, in which case it is
8796          * the first entry in that final set, and so this call is an attempt to
8797          * append out-of-order */
8798
8799         UV final_element = len - 1;
8800         array = invlist_array(invlist);
8801         if (   array[final_element] > start
8802             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8803         {
8804             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",
8805                      array[final_element], start,
8806                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8807         }
8808
8809         /* Here, it is a legal append.  If the new range begins 1 above the end
8810          * of the range below it, it is extending the range below it, so the
8811          * new first value not in the set is one greater than the newly
8812          * extended range.  */
8813         offset = *get_invlist_offset_addr(invlist);
8814         if (array[final_element] == start) {
8815             if (end != UV_MAX) {
8816                 array[final_element] = end + 1;
8817             }
8818             else {
8819                 /* But if the end is the maximum representable on the machine,
8820                  * assume that infinity was actually what was meant.  Just let
8821                  * the range that this would extend to have no end */
8822                 invlist_set_len(invlist, len - 1, offset);
8823             }
8824             return;
8825         }
8826     }
8827
8828     /* Here the new range doesn't extend any existing set.  Add it */
8829
8830     len += 2;   /* Includes an element each for the start and end of range */
8831
8832     /* If wll overflow the existing space, extend, which may cause the array to
8833      * be moved */
8834     if (max < len) {
8835         invlist_extend(invlist, len);
8836
8837         /* Have to set len here to avoid assert failure in invlist_array() */
8838         invlist_set_len(invlist, len, offset);
8839
8840         array = invlist_array(invlist);
8841     }
8842     else {
8843         invlist_set_len(invlist, len, offset);
8844     }
8845
8846     /* The next item on the list starts the range, the one after that is
8847      * one past the new range.  */
8848     array[len - 2] = start;
8849     if (end != UV_MAX) {
8850         array[len - 1] = end + 1;
8851     }
8852     else {
8853         /* But if the end is the maximum representable on the machine, just let
8854          * the range have no end */
8855         invlist_set_len(invlist, len - 1, offset);
8856     }
8857 }
8858
8859 SSize_t
8860 Perl__invlist_search(SV* const invlist, const UV cp)
8861 {
8862     /* Searches the inversion list for the entry that contains the input code
8863      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8864      * return value is the index into the list's array of the range that
8865      * contains <cp>, that is, 'i' such that
8866      *  array[i] <= cp < array[i+1]
8867      */
8868
8869     IV low = 0;
8870     IV mid;
8871     IV high = _invlist_len(invlist);
8872     const IV highest_element = high - 1;
8873     const UV* array;
8874
8875     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8876
8877     /* If list is empty, return failure. */
8878     if (high == 0) {
8879         return -1;
8880     }
8881
8882     /* (We can't get the array unless we know the list is non-empty) */
8883     array = invlist_array(invlist);
8884
8885     mid = invlist_previous_index(invlist);
8886     assert(mid >=0);
8887     if (mid > highest_element) {
8888         mid = highest_element;
8889     }
8890
8891     /* <mid> contains the cache of the result of the previous call to this
8892      * function (0 the first time).  See if this call is for the same result,
8893      * or if it is for mid-1.  This is under the theory that calls to this
8894      * function will often be for related code points that are near each other.
8895      * And benchmarks show that caching gives better results.  We also test
8896      * here if the code point is within the bounds of the list.  These tests
8897      * replace others that would have had to be made anyway to make sure that
8898      * the array bounds were not exceeded, and these give us extra information
8899      * at the same time */
8900     if (cp >= array[mid]) {
8901         if (cp >= array[highest_element]) {
8902             return highest_element;
8903         }
8904
8905         /* Here, array[mid] <= cp < array[highest_element].  This means that
8906          * the final element is not the answer, so can exclude it; it also
8907          * means that <mid> is not the final element, so can refer to 'mid + 1'
8908          * safely */
8909         if (cp < array[mid + 1]) {
8910             return mid;
8911         }
8912         high--;
8913         low = mid + 1;
8914     }
8915     else { /* cp < aray[mid] */
8916         if (cp < array[0]) { /* Fail if outside the array */
8917             return -1;
8918         }
8919         high = mid;
8920         if (cp >= array[mid - 1]) {
8921             goto found_entry;
8922         }
8923     }
8924
8925     /* Binary search.  What we are looking for is <i> such that
8926      *  array[i] <= cp < array[i+1]
8927      * The loop below converges on the i+1.  Note that there may not be an
8928      * (i+1)th element in the array, and things work nonetheless */
8929     while (low < high) {
8930         mid = (low + high) / 2;
8931         assert(mid <= highest_element);
8932         if (array[mid] <= cp) { /* cp >= array[mid] */
8933             low = mid + 1;
8934
8935             /* We could do this extra test to exit the loop early.
8936             if (cp < array[low]) {
8937                 return mid;
8938             }
8939             */
8940         }
8941         else { /* cp < array[mid] */
8942             high = mid;
8943         }
8944     }
8945
8946   found_entry:
8947     high--;
8948     invlist_set_previous_index(invlist, high);
8949     return high;
8950 }
8951
8952 void
8953 Perl__invlist_populate_swatch(SV* const invlist,
8954                               const UV start, const UV end, U8* swatch)
8955 {
8956     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8957      * but is used when the swash has an inversion list.  This makes this much
8958      * faster, as it uses a binary search instead of a linear one.  This is
8959      * intimately tied to that function, and perhaps should be in utf8.c,
8960      * except it is intimately tied to inversion lists as well.  It assumes
8961      * that <swatch> is all 0's on input */
8962
8963     UV current = start;
8964     const IV len = _invlist_len(invlist);
8965     IV i;
8966     const UV * array;
8967
8968     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8969
8970     if (len == 0) { /* Empty inversion list */
8971         return;
8972     }
8973
8974     array = invlist_array(invlist);
8975
8976     /* Find which element it is */
8977     i = _invlist_search(invlist, start);
8978
8979     /* We populate from <start> to <end> */
8980     while (current < end) {
8981         UV upper;
8982
8983         /* The inversion list gives the results for every possible code point
8984          * after the first one in the list.  Only those ranges whose index is
8985          * even are ones that the inversion list matches.  For the odd ones,
8986          * and if the initial code point is not in the list, we have to skip
8987          * forward to the next element */
8988         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8989             i++;
8990             if (i >= len) { /* Finished if beyond the end of the array */
8991                 return;
8992             }
8993             current = array[i];
8994             if (current >= end) {   /* Finished if beyond the end of what we
8995                                        are populating */
8996                 if (LIKELY(end < UV_MAX)) {
8997                     return;
8998                 }
8999
9000                 /* We get here when the upper bound is the maximum
9001                  * representable on the machine, and we are looking for just
9002                  * that code point.  Have to special case it */
9003                 i = len;
9004                 goto join_end_of_list;
9005             }
9006         }
9007         assert(current >= start);
9008
9009         /* The current range ends one below the next one, except don't go past
9010          * <end> */
9011         i++;
9012         upper = (i < len && array[i] < end) ? array[i] : end;
9013
9014         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
9015          * for each code point in it */
9016         for (; current < upper; current++) {
9017             const STRLEN offset = (STRLEN)(current - start);
9018             swatch[offset >> 3] |= 1 << (offset & 7);
9019         }
9020
9021       join_end_of_list:
9022
9023         /* Quit if at the end of the list */
9024         if (i >= len) {
9025
9026             /* But first, have to deal with the highest possible code point on
9027              * the platform.  The previous code assumes that <end> is one
9028              * beyond where we want to populate, but that is impossible at the
9029              * platform's infinity, so have to handle it specially */
9030             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
9031             {
9032                 const STRLEN offset = (STRLEN)(end - start);
9033                 swatch[offset >> 3] |= 1 << (offset & 7);
9034             }
9035             return;
9036         }
9037
9038         /* Advance to the next range, which will be for code points not in the
9039          * inversion list */
9040         current = array[i];
9041     }
9042
9043     return;
9044 }
9045
9046 void
9047 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9048                                          const bool complement_b, SV** output)
9049 {
9050     /* Take the union of two inversion lists and point '*output' to it.  On
9051      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9052      * even 'a' or 'b').  If to an inversion list, the contents of the original
9053      * list will be replaced by the union.  The first list, 'a', may be
9054      * NULL, in which case a copy of the second list is placed in '*output'.
9055      * If 'complement_b' is TRUE, the union is taken of the complement
9056      * (inversion) of 'b' instead of b itself.
9057      *
9058      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9059      * Richard Gillam, published by Addison-Wesley, and explained at some
9060      * length there.  The preface says to incorporate its examples into your
9061      * code at your own risk.
9062      *
9063      * The algorithm is like a merge sort. */
9064
9065     const UV* array_a;    /* a's array */
9066     const UV* array_b;
9067     UV len_a;       /* length of a's array */
9068     UV len_b;
9069
9070     SV* u;                      /* the resulting union */
9071     UV* array_u;
9072     UV len_u = 0;
9073
9074     UV i_a = 0;             /* current index into a's array */
9075     UV i_b = 0;
9076     UV i_u = 0;
9077
9078     /* running count, as explained in the algorithm source book; items are
9079      * stopped accumulating and are output when the count changes to/from 0.
9080      * The count is incremented when we start a range that's in an input's set,
9081      * and decremented when we start a range that's not in a set.  So this
9082      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9083      * and hence nothing goes into the union; 1, just one of the inputs is in
9084      * its set (and its current range gets added to the union); and 2 when both
9085      * inputs are in their sets.  */
9086     UV count = 0;
9087
9088     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9089     assert(a != b);
9090     assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
9091
9092     len_b = _invlist_len(b);
9093     if (len_b == 0) {
9094
9095         /* Here, 'b' is empty, hence it's complement is all possible code
9096          * points.  So if the union includes the complement of 'b', it includes
9097          * everything, and we need not even look at 'a'.  It's easiest to
9098          * create a new inversion list that matches everything.  */
9099         if (complement_b) {
9100             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9101
9102             if (*output == NULL) { /* If the output didn't exist, just point it
9103                                       at the new list */
9104                 *output = everything;
9105             }
9106             else { /* Otherwise, replace its contents with the new list */
9107                 invlist_replace_list_destroys_src(*output, everything);
9108                 SvREFCNT_dec_NN(everything);
9109             }
9110
9111             return;
9112         }
9113
9114         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9115          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9116          * output will be empty */
9117
9118         if (a == NULL || _invlist_len(a) == 0) {
9119             if (*output == NULL) {
9120                 *output = _new_invlist(0);
9121             }
9122             else {
9123                 invlist_clear(*output);
9124             }
9125             return;
9126         }
9127
9128         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9129          * union.  We can just return a copy of 'a' if '*output' doesn't point
9130          * to an existing list */
9131         if (*output == NULL) {
9132             *output = invlist_clone(a);
9133             return;
9134         }
9135
9136         /* If the output is to overwrite 'a', we have a no-op, as it's
9137          * already in 'a' */
9138         if (*output == a) {
9139             return;
9140         }
9141
9142         /* Here, '*output' is to be overwritten by 'a' */
9143         u = invlist_clone(a);
9144         invlist_replace_list_destroys_src(*output, u);
9145         SvREFCNT_dec_NN(u);
9146
9147         return;
9148     }
9149
9150     /* Here 'b' is not empty.  See about 'a' */
9151
9152     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9153
9154         /* Here, 'a' is empty (and b is not).  That means the union will come
9155          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9156          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9157          * the clone */
9158
9159         SV ** dest = (*output == NULL) ? output : &u;
9160         *dest = invlist_clone(b);
9161         if (complement_b) {
9162             _invlist_invert(*dest);
9163         }
9164
9165         if (dest == &u) {
9166             invlist_replace_list_destroys_src(*output, u);
9167             SvREFCNT_dec_NN(u);
9168         }
9169
9170         return;
9171     }
9172
9173     /* Here both lists exist and are non-empty */
9174     array_a = invlist_array(a);
9175     array_b = invlist_array(b);
9176
9177     /* If are to take the union of 'a' with the complement of b, set it
9178      * up so are looking at b's complement. */
9179     if (complement_b) {
9180
9181         /* To complement, we invert: if the first element is 0, remove it.  To
9182          * do this, we just pretend the array starts one later */
9183         if (array_b[0] == 0) {
9184             array_b++;
9185             len_b--;
9186         }
9187         else {
9188
9189             /* But if the first element is not zero, we pretend the list starts
9190              * at the 0 that is always stored immediately before the array. */
9191             array_b--;
9192             len_b++;
9193         }
9194     }
9195
9196     /* Size the union for the worst case: that the sets are completely
9197      * disjoint */
9198     u = _new_invlist(len_a + len_b);
9199
9200     /* Will contain U+0000 if either component does */
9201     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9202                                       || (len_b > 0 && array_b[0] == 0));
9203
9204     /* Go through each input list item by item, stopping when have exhausted
9205      * one of them */
9206     while (i_a < len_a && i_b < len_b) {
9207         UV cp;      /* The element to potentially add to the union's array */
9208         bool cp_in_set;   /* is it in the the input list's set or not */
9209
9210         /* We need to take one or the other of the two inputs for the union.
9211          * Since we are merging two sorted lists, we take the smaller of the
9212          * next items.  In case of a tie, we take first the one that is in its
9213          * set.  If we first took the one not in its set, it would decrement
9214          * the count, possibly to 0 which would cause it to be output as ending
9215          * the range, and the next time through we would take the same number,
9216          * and output it again as beginning the next range.  By doing it the
9217          * opposite way, there is no possibility that the count will be
9218          * momentarily decremented to 0, and thus the two adjoining ranges will
9219          * be seamlessly merged.  (In a tie and both are in the set or both not
9220          * in the set, it doesn't matter which we take first.) */
9221         if (       array_a[i_a] < array_b[i_b]
9222             || (   array_a[i_a] == array_b[i_b]
9223                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9224         {
9225             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9226             cp = array_a[i_a++];
9227         }
9228         else {
9229             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9230             cp = array_b[i_b++];
9231         }
9232
9233         /* Here, have chosen which of the two inputs to look at.  Only output
9234          * if the running count changes to/from 0, which marks the
9235          * beginning/end of a range that's in the set */
9236         if (cp_in_set) {
9237             if (count == 0) {
9238                 array_u[i_u++] = cp;
9239             }
9240             count++;
9241         }
9242         else {
9243             count--;
9244             if (count == 0) {
9245                 array_u[i_u++] = cp;
9246             }
9247         }
9248     }
9249
9250
9251     /* The loop above increments the index into exactly one of the input lists
9252      * each iteration, and ends when either index gets to its list end.  That
9253      * means the other index is lower than its end, and so something is
9254      * remaining in that one.  We decrement 'count', as explained below, if
9255      * that list is in its set.  (i_a and i_b each currently index the element
9256      * beyond the one we care about.) */
9257     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9258         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9259     {
9260         count--;
9261     }
9262
9263     /* Above we decremented 'count' if the list that had unexamined elements in
9264      * it was in its set.  This has made it so that 'count' being non-zero
9265      * means there isn't anything left to output; and 'count' equal to 0 means
9266      * that what is left to output is precisely that which is left in the
9267      * non-exhausted input list.
9268      *
9269      * To see why, note first that the exhausted input obviously has nothing
9270      * left to add to the union.  If it was in its set at its end, that means
9271      * the set extends from here to the platform's infinity, and hence so does
9272      * the union and the non-exhausted set is irrelevant.  The exhausted set
9273      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9274      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9275      * 'count' remains at 1.  This is consistent with the decremented 'count'
9276      * != 0 meaning there's nothing left to add to the union.
9277      *
9278      * But if the exhausted input wasn't in its set, it contributed 0 to
9279      * 'count', and the rest of the union will be whatever the other input is.
9280      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9281      * otherwise it gets decremented to 0.  This is consistent with 'count'
9282      * == 0 meaning the remainder of the union is whatever is left in the
9283      * non-exhausted list. */
9284     if (count != 0) {
9285         len_u = i_u;
9286     }
9287     else {
9288         IV copy_count = len_a - i_a;
9289         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9290             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9291         }
9292         else { /* The non-exhausted input is b */
9293             copy_count = len_b - i_b;
9294             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9295         }
9296         len_u = i_u + copy_count;
9297     }
9298
9299     /* Set the result to the final length, which can change the pointer to
9300      * array_u, so re-find it.  (Note that it is unlikely that this will
9301      * change, as we are shrinking the space, not enlarging it) */
9302     if (len_u != _invlist_len(u)) {
9303         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9304         invlist_trim(u);
9305         array_u = invlist_array(u);
9306     }
9307
9308     if (*output == NULL) {  /* Simply return the new inversion list */
9309         *output = u;
9310     }
9311     else {
9312         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9313          * could instead free '*output', and then set it to 'u', but experience
9314          * has shown [perl #127392] that if the input is a mortal, we can get a
9315          * huge build-up of these during regex compilation before they get
9316          * freed. */
9317         invlist_replace_list_destroys_src(*output, u);
9318         SvREFCNT_dec_NN(u);
9319     }
9320
9321     return;
9322 }
9323
9324 void
9325 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9326                                                const bool complement_b, SV** i)
9327 {
9328     /* Take the intersection of two inversion lists and point '*i' to it.  On
9329      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9330      * even 'a' or 'b').  If to an inversion list, the contents of the original
9331      * list will be replaced by the intersection.  The first list, 'a', may be
9332      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9333      * TRUE, the result will be the intersection of 'a' and the complement (or
9334      * inversion) of 'b' instead of 'b' directly.
9335      *
9336      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9337      * Richard Gillam, published by Addison-Wesley, and explained at some
9338      * length there.  The preface says to incorporate its examples into your
9339      * code at your own risk.  In fact, it had bugs
9340      *
9341      * The algorithm is like a merge sort, and is essentially the same as the
9342      * union above
9343      */
9344
9345     const UV* array_a;          /* a's array */
9346     const UV* array_b;
9347     UV len_a;   /* length of a's array */
9348     UV len_b;
9349
9350     SV* r;                   /* the resulting intersection */
9351     UV* array_r;
9352     UV len_r = 0;
9353
9354     UV i_a = 0;             /* current index into a's array */
9355     UV i_b = 0;
9356     UV i_r = 0;
9357
9358     /* running count of how many of the two inputs are postitioned at ranges
9359      * that are in their sets.  As explained in the algorithm source book,
9360      * items are stopped accumulating and are output when the count changes
9361      * to/from 2.  The count is incremented when we start a range that's in an
9362      * input's set, and decremented when we start a range that's not in a set.
9363      * Only when it is 2 are we in the intersection. */
9364     UV count = 0;
9365
9366     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9367     assert(a != b);
9368     assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
9369
9370     /* Special case if either one is empty */
9371     len_a = (a == NULL) ? 0 : _invlist_len(a);
9372     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9373         if (len_a != 0 && complement_b) {
9374
9375             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9376              * must be empty.  Here, also we are using 'b's complement, which
9377              * hence must be every possible code point.  Thus the intersection
9378              * is simply 'a'. */
9379
9380             if (*i == a) {  /* No-op */
9381                 return;
9382             }
9383
9384             if (*i == NULL) {
9385                 *i = invlist_clone(a);
9386                 return;
9387             }
9388
9389             r = invlist_clone(a);
9390             invlist_replace_list_destroys_src(*i, r);
9391             SvREFCNT_dec_NN(r);
9392             return;
9393         }
9394
9395         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9396          * intersection must be empty */
9397         if (*i == NULL) {
9398             *i = _new_invlist(0);
9399             return;
9400         }
9401
9402         invlist_clear(*i);
9403         return;
9404     }
9405
9406     /* Here both lists exist and are non-empty */
9407     array_a = invlist_array(a);
9408     array_b = invlist_array(b);
9409
9410     /* If are to take the intersection of 'a' with the complement of b, set it
9411      * up so are looking at b's complement. */
9412     if (complement_b) {
9413
9414         /* To complement, we invert: if the first element is 0, remove it.  To
9415          * do this, we just pretend the array starts one later */
9416         if (array_b[0] == 0) {
9417             array_b++;
9418             len_b--;
9419         }
9420         else {
9421
9422             /* But if the first element is not zero, we pretend the list starts
9423              * at the 0 that is always stored immediately before the array. */
9424             array_b--;
9425             len_b++;
9426         }
9427     }
9428
9429     /* Size the intersection for the worst case: that the intersection ends up
9430      * fragmenting everything to be completely disjoint */
9431     r= _new_invlist(len_a + len_b);
9432
9433     /* Will contain U+0000 iff both components do */
9434     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9435                                      && len_b > 0 && array_b[0] == 0);
9436
9437     /* Go through each list item by item, stopping when have exhausted one of
9438      * them */
9439     while (i_a < len_a && i_b < len_b) {
9440         UV cp;      /* The element to potentially add to the intersection's
9441                        array */
9442         bool cp_in_set; /* Is it in the input list's set or not */
9443
9444         /* We need to take one or the other of the two inputs for the
9445          * intersection.  Since we are merging two sorted lists, we take the
9446          * smaller of the next items.  In case of a tie, we take first the one
9447          * that is not in its set (a difference from the union algorithm).  If
9448          * we first took the one in its set, it would increment the count,
9449          * possibly to 2 which would cause it to be output as starting a range
9450          * in the intersection, and the next time through we would take that
9451          * same number, and output it again as ending the set.  By doing the
9452          * opposite of this, there is no possibility that the count will be
9453          * momentarily incremented to 2.  (In a tie and both are in the set or
9454          * both not in the set, it doesn't matter which we take first.) */
9455         if (       array_a[i_a] < array_b[i_b]
9456             || (   array_a[i_a] == array_b[i_b]
9457                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9458         {
9459             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9460             cp = array_a[i_a++];
9461         }
9462         else {
9463             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9464             cp= array_b[i_b++];
9465         }
9466
9467         /* Here, have chosen which of the two inputs to look at.  Only output
9468          * if the running count changes to/from 2, which marks the
9469          * beginning/end of a range that's in the intersection */
9470         if (cp_in_set) {
9471             count++;
9472             if (count == 2) {
9473                 array_r[i_r++] = cp;
9474             }
9475         }
9476         else {
9477             if (count == 2) {
9478                 array_r[i_r++] = cp;
9479             }
9480             count--;
9481         }
9482
9483     }
9484
9485     /* The loop above increments the index into exactly one of the input lists
9486      * each iteration, and ends when either index gets to its list end.  That
9487      * means the other index is lower than its end, and so something is
9488      * remaining in that one.  We increment 'count', as explained below, if the
9489      * exhausted list was in its set.  (i_a and i_b each currently index the
9490      * element beyond the one we care about.) */
9491     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9492         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9493     {
9494         count++;
9495     }
9496
9497     /* Above we incremented 'count' if the exhausted list was in its set.  This
9498      * has made it so that 'count' being below 2 means there is nothing left to
9499      * output; otheriwse what's left to add to the intersection is precisely
9500      * that which is left in the non-exhausted input list.
9501      *
9502      * To see why, note first that the exhausted input obviously has nothing
9503      * left to affect the intersection.  If it was in its set at its end, that
9504      * means the set extends from here to the platform's infinity, and hence
9505      * anything in the non-exhausted's list will be in the intersection, and
9506      * anything not in it won't be.  Hence, the rest of the intersection is
9507      * precisely what's in the non-exhausted list  The exhausted set also
9508      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9509      * it means 'count' is now at least 2.  This is consistent with the
9510      * incremented 'count' being >= 2 means to add the non-exhausted list to
9511      * the intersection.
9512      *
9513      * But if the exhausted input wasn't in its set, it contributed 0 to
9514      * 'count', and the intersection can't include anything further; the
9515      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9516      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9517      * further to add to the intersection. */
9518     if (count < 2) { /* Nothing left to put in the intersection. */
9519         len_r = i_r;
9520     }
9521     else { /* copy the non-exhausted list, unchanged. */
9522         IV copy_count = len_a - i_a;
9523         if (copy_count > 0) {   /* a is the one with stuff left */
9524             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9525         }
9526         else {  /* b is the one with stuff left */
9527             copy_count = len_b - i_b;
9528             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9529         }
9530         len_r = i_r + copy_count;
9531     }
9532
9533     /* Set the result to the final length, which can change the pointer to
9534      * array_r, so re-find it.  (Note that it is unlikely that this will
9535      * change, as we are shrinking the space, not enlarging it) */
9536     if (len_r != _invlist_len(r)) {
9537         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9538         invlist_trim(r);
9539         array_r = invlist_array(r);
9540     }
9541
9542     if (*i == NULL) { /* Simply return the calculated intersection */
9543         *i = r;
9544     }
9545     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9546               instead free '*i', and then set it to 'r', but experience has
9547               shown [perl #127392] that if the input is a mortal, we can get a
9548               huge build-up of these during regex compilation before they get
9549               freed. */
9550         if (len_r) {
9551             invlist_replace_list_destroys_src(*i, r);
9552         }
9553         else {
9554             invlist_clear(*i);
9555         }
9556         SvREFCNT_dec_NN(r);
9557     }
9558
9559     return;
9560 }
9561
9562 SV*
9563 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9564 {
9565     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9566      * set.  A pointer to the inversion list is returned.  This may actually be
9567      * a new list, in which case the passed in one has been destroyed.  The
9568      * passed-in inversion list can be NULL, in which case a new one is created
9569      * with just the one range in it.  The new list is not necessarily
9570      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9571      * result of this function.  The gain would not be large, and in many
9572      * cases, this is called multiple times on a single inversion list, so
9573      * anything freed may almost immediately be needed again.
9574      *
9575      * This used to mostly call the 'union' routine, but that is much more
9576      * heavyweight than really needed for a single range addition */
9577
9578     UV* array;              /* The array implementing the inversion list */
9579     UV len;                 /* How many elements in 'array' */
9580     SSize_t i_s;            /* index into the invlist array where 'start'
9581                                should go */
9582     SSize_t i_e = 0;        /* And the index where 'end' should go */
9583     UV cur_highest;         /* The highest code point in the inversion list
9584                                upon entry to this function */
9585
9586     /* This range becomes the whole inversion list if none already existed */
9587     if (invlist == NULL) {
9588         invlist = _new_invlist(2);
9589         _append_range_to_invlist(invlist, start, end);
9590         return invlist;
9591     }
9592
9593     /* Likewise, if the inversion list is currently empty */
9594     len = _invlist_len(invlist);
9595     if (len == 0) {
9596         _append_range_to_invlist(invlist, start, end);
9597         return invlist;
9598     }
9599
9600     /* Starting here, we have to know the internals of the list */
9601     array = invlist_array(invlist);
9602
9603     /* If the new range ends higher than the current highest ... */
9604     cur_highest = invlist_highest(invlist);
9605     if (end > cur_highest) {
9606
9607         /* If the whole range is higher, we can just append it */
9608         if (start > cur_highest) {
9609             _append_range_to_invlist(invlist, start, end);
9610             return invlist;
9611         }
9612
9613         /* Otherwise, add the portion that is higher ... */
9614         _append_range_to_invlist(invlist, cur_highest + 1, end);
9615
9616         /* ... and continue on below to handle the rest.  As a result of the
9617          * above append, we know that the index of the end of the range is the
9618          * final even numbered one of the array.  Recall that the final element
9619          * always starts a range that extends to infinity.  If that range is in
9620          * the set (meaning the set goes from here to infinity), it will be an
9621          * even index, but if it isn't in the set, it's odd, and the final
9622          * range in the set is one less, which is even. */
9623         if (end == UV_MAX) {
9624             i_e = len;
9625         }
9626         else {
9627             i_e = len - 2;
9628         }
9629     }
9630
9631     /* We have dealt with appending, now see about prepending.  If the new
9632      * range starts lower than the current lowest ... */
9633     if (start < array[0]) {
9634
9635         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
9636          * Let the union code handle it, rather than having to know the
9637          * trickiness in two code places.  */
9638         if (UNLIKELY(start == 0)) {
9639             SV* range_invlist;
9640
9641             range_invlist = _new_invlist(2);
9642             _append_range_to_invlist(range_invlist, start, end);
9643
9644             _invlist_union(invlist, range_invlist, &invlist);
9645
9646             SvREFCNT_dec_NN(range_invlist);
9647
9648             return invlist;
9649         }
9650
9651         /* If the whole new range comes before the first entry, and doesn't
9652          * extend it, we have to insert it as an additional range */
9653         if (end < array[0] - 1) {
9654             i_s = i_e = -1;
9655             goto splice_in_new_range;
9656         }
9657
9658         /* Here the new range adjoins the existing first range, extending it
9659          * downwards. */
9660         array[0] = start;
9661
9662         /* And continue on below to handle the rest.  We know that the index of
9663          * the beginning of the range is the first one of the array */
9664         i_s = 0;
9665     }
9666     else { /* Not prepending any part of the new range to the existing list.
9667             * Find where in the list it should go.  This finds i_s, such that:
9668             *     invlist[i_s] <= start < array[i_s+1]
9669             */
9670         i_s = _invlist_search(invlist, start);
9671     }
9672
9673     /* At this point, any extending before the beginning of the inversion list
9674      * and/or after the end has been done.  This has made it so that, in the
9675      * code below, each endpoint of the new range is either in a range that is
9676      * in the set, or is in a gap between two ranges that are.  This means we
9677      * don't have to worry about exceeding the array bounds.
9678      *
9679      * Find where in the list the new range ends (but we can skip this if we
9680      * have already determined what it is, or if it will be the same as i_s,
9681      * which we already have computed) */
9682     if (i_e == 0) {
9683         i_e = (start == end)
9684               ? i_s
9685               : _invlist_search(invlist, end);
9686     }
9687
9688     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
9689      * is a range that goes to infinity there is no element at invlist[i_e+1],
9690      * so only the first relation holds. */
9691
9692     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9693
9694         /* Here, the ranges on either side of the beginning of the new range
9695          * are in the set, and this range starts in the gap between them.
9696          *
9697          * The new range extends the range above it downwards if the new range
9698          * ends at or above that range's start */
9699         const bool extends_the_range_above = (   end == UV_MAX
9700                                               || end + 1 >= array[i_s+1]);
9701
9702         /* The new range extends the range below it upwards if it begins just
9703          * after where that range ends */
9704         if (start == array[i_s]) {
9705
9706             /* If the new range fills the entire gap between the other ranges,
9707              * they will get merged together.  Other ranges may also get
9708              * merged, depending on how many of them the new range spans.  In
9709              * the general case, we do the merge later, just once, after we
9710              * figure out how many to merge.  But in the case where the new
9711              * range exactly spans just this one gap (possibly extending into
9712              * the one above), we do the merge here, and an early exit.  This
9713              * is done here to avoid having to special case later. */
9714             if (i_e - i_s <= 1) {
9715
9716                 /* If i_e - i_s == 1, it means that the new range terminates
9717                  * within the range above, and hence 'extends_the_range_above'
9718                  * must be true.  (If the range above it extends to infinity,
9719                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
9720                  * will be 0, so no harm done.) */
9721                 if (extends_the_range_above) {
9722                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
9723                     invlist_set_len(invlist,
9724                                     len - 2,
9725                                     *(get_invlist_offset_addr(invlist)));
9726                     return invlist;
9727                 }
9728
9729                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
9730                  * to the same range, and below we are about to decrement i_s
9731                  * */
9732                 i_e--;
9733             }
9734
9735             /* Here, the new range is adjacent to the one below.  (It may also
9736              * span beyond the range above, but that will get resolved later.)
9737              * Extend the range below to include this one. */
9738             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
9739             i_s--;
9740             start = array[i_s];
9741         }
9742         else if (extends_the_range_above) {
9743
9744             /* Here the new range only extends the range above it, but not the
9745              * one below.  It merges with the one above.  Again, we keep i_e
9746              * and i_s in sync if they point to the same range */
9747             if (i_e == i_s) {
9748                 i_e++;
9749             }
9750             i_s++;
9751             array[i_s] = start;
9752         }
9753     }
9754
9755     /* Here, we've dealt with the new range start extending any adjoining
9756      * existing ranges.
9757      *
9758      * If the new range extends to infinity, it is now the final one,
9759      * regardless of what was there before */
9760     if (UNLIKELY(end == UV_MAX)) {
9761         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
9762         return invlist;
9763     }
9764
9765     /* If i_e started as == i_s, it has also been dealt with,
9766      * and been updated to the new i_s, which will fail the following if */
9767     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
9768
9769         /* Here, the ranges on either side of the end of the new range are in
9770          * the set, and this range ends in the gap between them.
9771          *
9772          * If this range is adjacent to (hence extends) the range above it, it
9773          * becomes part of that range; likewise if it extends the range below,
9774          * it becomes part of that range */
9775         if (end + 1 == array[i_e+1]) {
9776             i_e++;
9777             array[i_e] = start;
9778         }
9779         else if (start <= array[i_e]) {
9780             array[i_e] = end + 1;
9781             i_e--;
9782         }
9783     }
9784
9785     if (i_s == i_e) {
9786
9787         /* If the range fits entirely in an existing range (as possibly already
9788          * extended above), it doesn't add anything new */
9789         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9790             return invlist;
9791         }
9792
9793         /* Here, no part of the range is in the list.  Must add it.  It will
9794          * occupy 2 more slots */
9795       splice_in_new_range:
9796
9797         invlist_extend(invlist, len + 2);
9798         array = invlist_array(invlist);
9799         /* Move the rest of the array down two slots. Don't include any
9800          * trailing NUL */
9801         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
9802
9803         /* Do the actual splice */
9804         array[i_e+1] = start;
9805         array[i_e+2] = end + 1;
9806         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
9807         return invlist;
9808     }
9809
9810     /* Here the new range crossed the boundaries of a pre-existing range.  The
9811      * code above has adjusted things so that both ends are in ranges that are
9812      * in the set.  This means everything in between must also be in the set.
9813      * Just squash things together */
9814     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
9815     invlist_set_len(invlist,
9816                     len - i_e + i_s,
9817                     *(get_invlist_offset_addr(invlist)));
9818
9819     return invlist;
9820 }
9821
9822 SV*
9823 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9824                                  UV** other_elements_ptr)
9825 {
9826     /* Create and return an inversion list whose contents are to be populated
9827      * by the caller.  The caller gives the number of elements (in 'size') and
9828      * the very first element ('element0').  This function will set
9829      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9830      * are to be placed.
9831      *
9832      * Obviously there is some trust involved that the caller will properly
9833      * fill in the other elements of the array.
9834      *
9835      * (The first element needs to be passed in, as the underlying code does
9836      * things differently depending on whether it is zero or non-zero) */
9837
9838     SV* invlist = _new_invlist(size);
9839     bool offset;
9840
9841     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9842
9843     invlist = add_cp_to_invlist(invlist, element0);
9844     offset = *get_invlist_offset_addr(invlist);
9845
9846     invlist_set_len(invlist, size, offset);
9847     *other_elements_ptr = invlist_array(invlist) + 1;
9848     return invlist;
9849 }
9850
9851 #endif
9852
9853 PERL_STATIC_INLINE SV*
9854 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9855     return _add_range_to_invlist(invlist, cp, cp);
9856 }
9857
9858 #ifndef PERL_IN_XSUB_RE
9859 void
9860 Perl__invlist_invert(pTHX_ SV* const invlist)
9861 {
9862     /* Complement the input inversion list.  This adds a 0 if the list didn't
9863      * have a zero; removes it otherwise.  As described above, the data
9864      * structure is set up so that this is very efficient */
9865
9866     PERL_ARGS_ASSERT__INVLIST_INVERT;
9867
9868     assert(! invlist_is_iterating(invlist));
9869
9870     /* The inverse of matching nothing is matching everything */
9871     if (_invlist_len(invlist) == 0) {
9872         _append_range_to_invlist(invlist, 0, UV_MAX);
9873         return;
9874     }
9875
9876     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9877 }
9878
9879 #endif
9880
9881 PERL_STATIC_INLINE SV*
9882 S_invlist_clone(pTHX_ SV* const invlist)
9883 {
9884
9885     /* Return a new inversion list that is a copy of the input one, which is
9886      * unchanged.  The new list will not be mortal even if the old one was. */
9887
9888     /* Need to allocate extra space to accommodate Perl's addition of a
9889      * trailing NUL to SvPV's, since it thinks they are always strings */
9890     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9891     STRLEN physical_length = SvCUR(invlist);
9892     bool offset = *(get_invlist_offset_addr(invlist));
9893
9894     PERL_ARGS_ASSERT_INVLIST_CLONE;
9895
9896     *(get_invlist_offset_addr(new_invlist)) = offset;
9897     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9898     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9899
9900     return new_invlist;
9901 }
9902
9903 PERL_STATIC_INLINE STRLEN*
9904 S_get_invlist_iter_addr(SV* invlist)
9905 {
9906     /* Return the address of the UV that contains the current iteration
9907      * position */
9908
9909     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9910
9911     assert(SvTYPE(invlist) == SVt_INVLIST);
9912
9913     return &(((XINVLIST*) SvANY(invlist))->iterator);
9914 }
9915
9916 PERL_STATIC_INLINE void
9917 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9918 {
9919     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9920
9921     *get_invlist_iter_addr(invlist) = 0;
9922 }
9923
9924 PERL_STATIC_INLINE void
9925 S_invlist_iterfinish(SV* invlist)
9926 {
9927     /* Terminate iterator for invlist.  This is to catch development errors.
9928      * Any iteration that is interrupted before completed should call this
9929      * function.  Functions that add code points anywhere else but to the end
9930      * of an inversion list assert that they are not in the middle of an
9931      * iteration.  If they were, the addition would make the iteration
9932      * problematical: if the iteration hadn't reached the place where things
9933      * were being added, it would be ok */
9934
9935     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9936
9937     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9938 }
9939
9940 STATIC bool
9941 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9942 {
9943     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9944      * This call sets in <*start> and <*end>, the next range in <invlist>.
9945      * Returns <TRUE> if successful and the next call will return the next
9946      * range; <FALSE> if was already at the end of the list.  If the latter,
9947      * <*start> and <*end> are unchanged, and the next call to this function
9948      * will start over at the beginning of the list */
9949
9950     STRLEN* pos = get_invlist_iter_addr(invlist);
9951     UV len = _invlist_len(invlist);
9952     UV *array;
9953
9954     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9955
9956     if (*pos >= len) {
9957         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9958         return FALSE;
9959     }
9960
9961     array = invlist_array(invlist);
9962
9963     *start = array[(*pos)++];
9964
9965     if (*pos >= len) {
9966         *end = UV_MAX;
9967     }
9968     else {
9969         *end = array[(*pos)++] - 1;
9970     }
9971
9972     return TRUE;
9973 }
9974
9975 PERL_STATIC_INLINE UV
9976 S_invlist_highest(SV* const invlist)
9977 {
9978     /* Returns the highest code point that matches an inversion list.  This API
9979      * has an ambiguity, as it returns 0 under either the highest is actually
9980      * 0, or if the list is empty.  If this distinction matters to you, check
9981      * for emptiness before calling this function */
9982
9983     UV len = _invlist_len(invlist);
9984     UV *array;
9985
9986     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9987
9988     if (len == 0) {
9989         return 0;
9990     }
9991
9992     array = invlist_array(invlist);
9993
9994     /* The last element in the array in the inversion list always starts a
9995      * range that goes to infinity.  That range may be for code points that are
9996      * matched in the inversion list, or it may be for ones that aren't
9997      * matched.  In the latter case, the highest code point in the set is one
9998      * less than the beginning of this range; otherwise it is the final element
9999      * of this range: infinity */
10000     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
10001            ? UV_MAX
10002            : array[len - 1] - 1;
10003 }
10004
10005 STATIC SV *
10006 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
10007 {
10008     /* Get the contents of an inversion list into a string SV so that they can
10009      * be printed out.  If 'traditional_style' is TRUE, it uses the format
10010      * traditionally done for debug tracing; otherwise it uses a format
10011      * suitable for just copying to the output, with blanks between ranges and
10012      * a dash between range components */
10013
10014     UV start, end;
10015     SV* output;
10016     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
10017     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
10018
10019     if (traditional_style) {
10020         output = newSVpvs("\n");
10021     }
10022     else {
10023         output = newSVpvs("");
10024     }
10025
10026     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
10027
10028     assert(! invlist_is_iterating(invlist));
10029
10030     invlist_iterinit(invlist);
10031     while (invlist_iternext(invlist, &start, &end)) {
10032         if (end == UV_MAX) {
10033             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFINITY%c",
10034                                           start, intra_range_delimiter,
10035                                                  inter_range_delimiter);
10036         }
10037         else if (end != start) {
10038             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10039                                           start,
10040                                                    intra_range_delimiter,
10041                                                   end, inter_range_delimiter);
10042         }
10043         else {
10044             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10045                                           start, inter_range_delimiter);
10046         }
10047     }
10048
10049     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10050         SvCUR_set(output, SvCUR(output) - 1);
10051     }
10052
10053     return output;
10054 }
10055
10056 #ifndef PERL_IN_XSUB_RE
10057 void
10058 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10059                          const char * const indent, SV* const invlist)
10060 {
10061     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10062      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10063      * the string 'indent'.  The output looks like this:
10064          [0] 0x000A .. 0x000D
10065          [2] 0x0085
10066          [4] 0x2028 .. 0x2029
10067          [6] 0x3104 .. INFINITY
10068      * This means that the first range of code points matched by the list are
10069      * 0xA through 0xD; the second range contains only the single code point
10070      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10071      * are used to define each range (except if the final range extends to
10072      * infinity, only a single element is needed).  The array index of the
10073      * first element for the corresponding range is given in brackets. */
10074
10075     UV start, end;
10076     STRLEN count = 0;
10077
10078     PERL_ARGS_ASSERT__INVLIST_DUMP;
10079
10080     if (invlist_is_iterating(invlist)) {
10081         Perl_dump_indent(aTHX_ level, file,
10082              "%sCan't dump inversion list because is in middle of iterating\n",
10083              indent);
10084         return;
10085     }
10086
10087     invlist_iterinit(invlist);
10088     while (invlist_iternext(invlist, &start, &end)) {
10089         if (end == UV_MAX) {
10090             Perl_dump_indent(aTHX_ level, file,
10091                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFINITY\n",
10092                                    indent, (UV)count, start);
10093         }
10094         else if (end != start) {
10095             Perl_dump_indent(aTHX_ level, file,
10096                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10097                                 indent, (UV)count, start,         end);
10098         }
10099         else {
10100             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10101                                             indent, (UV)count, start);
10102         }
10103         count += 2;
10104     }
10105 }
10106
10107 void
10108 Perl__load_PL_utf8_foldclosures (pTHX)
10109 {
10110     assert(! PL_utf8_foldclosures);
10111
10112     /* If the folds haven't been read in, call a fold function
10113      * to force that */
10114     if (! PL_utf8_tofold) {
10115         U8 dummy[UTF8_MAXBYTES_CASE+1];
10116         const U8 hyphen[] = HYPHEN_UTF8;
10117
10118         /* This string is just a short named one above \xff */
10119         toFOLD_utf8_safe(hyphen, hyphen + sizeof(hyphen) - 1, dummy, NULL);
10120         assert(PL_utf8_tofold); /* Verify that worked */
10121     }
10122     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10123 }
10124 #endif
10125
10126 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10127 bool
10128 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10129 {
10130     /* Return a boolean as to if the two passed in inversion lists are
10131      * identical.  The final argument, if TRUE, says to take the complement of
10132      * the second inversion list before doing the comparison */
10133
10134     const UV* array_a = invlist_array(a);
10135     const UV* array_b = invlist_array(b);
10136     UV len_a = _invlist_len(a);
10137     UV len_b = _invlist_len(b);
10138
10139     PERL_ARGS_ASSERT__INVLISTEQ;
10140
10141     /* If are to compare 'a' with the complement of b, set it
10142      * up so are looking at b's complement. */
10143     if (complement_b) {
10144
10145         /* The complement of nothing is everything, so <a> would have to have
10146          * just one element, starting at zero (ending at infinity) */
10147         if (len_b == 0) {
10148             return (len_a == 1 && array_a[0] == 0);
10149         }
10150         else if (array_b[0] == 0) {
10151
10152             /* Otherwise, to complement, we invert.  Here, the first element is
10153              * 0, just remove it.  To do this, we just pretend the array starts
10154              * one later */
10155
10156             array_b++;
10157             len_b--;
10158         }
10159         else {
10160
10161             /* But if the first element is not zero, we pretend the list starts
10162              * at the 0 that is always stored immediately before the array. */
10163             array_b--;
10164             len_b++;
10165         }
10166     }
10167
10168     return    len_a == len_b
10169            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10170
10171 }
10172 #endif
10173
10174 /*
10175  * As best we can, determine the characters that can match the start of
10176  * the given EXACTF-ish node.
10177  *
10178  * Returns the invlist as a new SV*; it is the caller's responsibility to
10179  * call SvREFCNT_dec() when done with it.
10180  */
10181 STATIC SV*
10182 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10183 {
10184     const U8 * s = (U8*)STRING(node);
10185     SSize_t bytelen = STR_LEN(node);
10186     UV uc;
10187     /* Start out big enough for 2 separate code points */
10188     SV* invlist = _new_invlist(4);
10189
10190     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10191
10192     if (! UTF) {
10193         uc = *s;
10194
10195         /* We punt and assume can match anything if the node begins
10196          * with a multi-character fold.  Things are complicated.  For
10197          * example, /ffi/i could match any of:
10198          *  "\N{LATIN SMALL LIGATURE FFI}"
10199          *  "\N{LATIN SMALL LIGATURE FF}I"
10200          *  "F\N{LATIN SMALL LIGATURE FI}"
10201          *  plus several other things; and making sure we have all the
10202          *  possibilities is hard. */
10203         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10204             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10205         }
10206         else {
10207             /* Any Latin1 range character can potentially match any
10208              * other depending on the locale */
10209             if (OP(node) == EXACTFL) {
10210                 _invlist_union(invlist, PL_Latin1, &invlist);
10211             }
10212             else {
10213                 /* But otherwise, it matches at least itself.  We can
10214                  * quickly tell if it has a distinct fold, and if so,
10215                  * it matches that as well */
10216                 invlist = add_cp_to_invlist(invlist, uc);
10217                 if (IS_IN_SOME_FOLD_L1(uc))
10218                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10219             }
10220
10221             /* Some characters match above-Latin1 ones under /i.  This
10222              * is true of EXACTFL ones when the locale is UTF-8 */
10223             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10224                 && (! isASCII(uc) || (OP(node) != EXACTFA
10225                                     && OP(node) != EXACTFA_NO_TRIE)))
10226             {
10227                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10228             }
10229         }
10230     }
10231     else {  /* Pattern is UTF-8 */
10232         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10233         STRLEN foldlen = UTF8SKIP(s);
10234         const U8* e = s + bytelen;
10235         SV** listp;
10236
10237         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10238
10239         /* The only code points that aren't folded in a UTF EXACTFish
10240          * node are are the problematic ones in EXACTFL nodes */
10241         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10242             /* We need to check for the possibility that this EXACTFL
10243              * node begins with a multi-char fold.  Therefore we fold
10244              * the first few characters of it so that we can make that
10245              * check */
10246             U8 *d = folded;
10247             int i;
10248
10249             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10250                 if (isASCII(*s)) {
10251                     *(d++) = (U8) toFOLD(*s);
10252                     s++;
10253                 }
10254                 else {
10255                     STRLEN len;
10256                     toFOLD_utf8_safe(s, e, d, &len);
10257                     d += len;
10258                     s += UTF8SKIP(s);
10259                 }
10260             }
10261
10262             /* And set up so the code below that looks in this folded
10263              * buffer instead of the node's string */
10264             e = d;
10265             foldlen = UTF8SKIP(folded);
10266             s = folded;
10267         }
10268
10269         /* When we reach here 's' points to the fold of the first
10270          * character(s) of the node; and 'e' points to far enough along
10271          * the folded string to be just past any possible multi-char
10272          * fold. 'foldlen' is the length in bytes of the first
10273          * character in 's'
10274          *
10275          * Unlike the non-UTF-8 case, the macro for determining if a
10276          * string is a multi-char fold requires all the characters to
10277          * already be folded.  This is because of all the complications
10278          * if not.  Note that they are folded anyway, except in EXACTFL
10279          * nodes.  Like the non-UTF case above, we punt if the node
10280          * begins with a multi-char fold  */
10281
10282         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10283             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10284         }
10285         else {  /* Single char fold */
10286
10287             /* It matches all the things that fold to it, which are
10288              * found in PL_utf8_foldclosures (including itself) */
10289             invlist = add_cp_to_invlist(invlist, uc);
10290             if (! PL_utf8_foldclosures)
10291                 _load_PL_utf8_foldclosures();
10292             if ((listp = hv_fetch(PL_utf8_foldclosures,
10293                                 (char *) s, foldlen, FALSE)))
10294             {
10295                 AV* list = (AV*) *listp;
10296                 IV k;
10297                 for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
10298                     SV** c_p = av_fetch(list, k, FALSE);
10299                     UV c;
10300                     assert(c_p);
10301
10302                     c = SvUV(*c_p);
10303
10304                     /* /aa doesn't allow folds between ASCII and non- */
10305                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
10306                         && isASCII(c) != isASCII(uc))
10307                     {
10308                         continue;
10309                     }
10310
10311                     invlist = add_cp_to_invlist(invlist, c);
10312                 }
10313             }
10314         }
10315     }
10316
10317     return invlist;
10318 }
10319
10320 #undef HEADER_LENGTH
10321 #undef TO_INTERNAL_SIZE
10322 #undef FROM_INTERNAL_SIZE
10323 #undef INVLIST_VERSION_ID
10324
10325 /* End of inversion list object */
10326
10327 STATIC void
10328 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10329 {
10330     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10331      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10332      * should point to the first flag; it is updated on output to point to the
10333      * final ')' or ':'.  There needs to be at least one flag, or this will
10334      * abort */
10335
10336     /* for (?g), (?gc), and (?o) warnings; warning
10337        about (?c) will warn about (?g) -- japhy    */
10338
10339 #define WASTED_O  0x01
10340 #define WASTED_G  0x02
10341 #define WASTED_C  0x04
10342 #define WASTED_GC (WASTED_G|WASTED_C)
10343     I32 wastedflags = 0x00;
10344     U32 posflags = 0, negflags = 0;
10345     U32 *flagsp = &posflags;
10346     char has_charset_modifier = '\0';
10347     regex_charset cs;
10348     bool has_use_defaults = FALSE;
10349     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10350     int x_mod_count = 0;
10351
10352     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10353
10354     /* '^' as an initial flag sets certain defaults */
10355     if (UCHARAT(RExC_parse) == '^') {
10356         RExC_parse++;
10357         has_use_defaults = TRUE;
10358         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10359         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10360                                         ? REGEX_UNICODE_CHARSET
10361                                         : REGEX_DEPENDS_CHARSET);
10362     }
10363
10364     cs = get_regex_charset(RExC_flags);
10365     if (cs == REGEX_DEPENDS_CHARSET
10366         && (RExC_utf8 || RExC_uni_semantics))
10367     {
10368         cs = REGEX_UNICODE_CHARSET;
10369     }
10370
10371     while (RExC_parse < RExC_end) {
10372         /* && strchr("iogcmsx", *RExC_parse) */
10373         /* (?g), (?gc) and (?o) are useless here
10374            and must be globally applied -- japhy */
10375         switch (*RExC_parse) {
10376
10377             /* Code for the imsxn flags */
10378             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10379
10380             case LOCALE_PAT_MOD:
10381                 if (has_charset_modifier) {
10382                     goto excess_modifier;
10383                 }
10384                 else if (flagsp == &negflags) {
10385                     goto neg_modifier;
10386                 }
10387                 cs = REGEX_LOCALE_CHARSET;
10388                 has_charset_modifier = LOCALE_PAT_MOD;
10389                 break;
10390             case UNICODE_PAT_MOD:
10391                 if (has_charset_modifier) {
10392                     goto excess_modifier;
10393                 }
10394                 else if (flagsp == &negflags) {
10395                     goto neg_modifier;
10396                 }
10397                 cs = REGEX_UNICODE_CHARSET;
10398                 has_charset_modifier = UNICODE_PAT_MOD;
10399                 break;
10400             case ASCII_RESTRICT_PAT_MOD:
10401                 if (flagsp == &negflags) {
10402                     goto neg_modifier;
10403                 }
10404                 if (has_charset_modifier) {
10405                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10406                         goto excess_modifier;
10407                     }
10408                     /* Doubled modifier implies more restricted */
10409                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10410                 }
10411                 else {
10412                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10413                 }
10414                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10415                 break;
10416             case DEPENDS_PAT_MOD:
10417                 if (has_use_defaults) {
10418                     goto fail_modifiers;
10419                 }
10420                 else if (flagsp == &negflags) {
10421                     goto neg_modifier;
10422                 }
10423                 else if (has_charset_modifier) {
10424                     goto excess_modifier;
10425                 }
10426
10427                 /* The dual charset means unicode semantics if the
10428                  * pattern (or target, not known until runtime) are
10429                  * utf8, or something in the pattern indicates unicode
10430                  * semantics */
10431                 cs = (RExC_utf8 || RExC_uni_semantics)
10432                      ? REGEX_UNICODE_CHARSET
10433                      : REGEX_DEPENDS_CHARSET;
10434                 has_charset_modifier = DEPENDS_PAT_MOD;
10435                 break;
10436               excess_modifier:
10437                 RExC_parse++;
10438                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10439                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10440                 }
10441                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10442                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10443                                         *(RExC_parse - 1));
10444                 }
10445                 else {
10446                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10447                 }
10448                 NOT_REACHED; /*NOTREACHED*/
10449               neg_modifier:
10450                 RExC_parse++;
10451                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10452                                     *(RExC_parse - 1));
10453                 NOT_REACHED; /*NOTREACHED*/
10454             case ONCE_PAT_MOD: /* 'o' */
10455             case GLOBAL_PAT_MOD: /* 'g' */
10456                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10457                     const I32 wflagbit = *RExC_parse == 'o'
10458                                          ? WASTED_O
10459                                          : WASTED_G;
10460                     if (! (wastedflags & wflagbit) ) {
10461                         wastedflags |= wflagbit;
10462                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10463                         vWARN5(
10464                             RExC_parse + 1,
10465                             "Useless (%s%c) - %suse /%c modifier",
10466                             flagsp == &negflags ? "?-" : "?",
10467                             *RExC_parse,
10468                             flagsp == &negflags ? "don't " : "",
10469                             *RExC_parse
10470                         );
10471                     }
10472                 }
10473                 break;
10474
10475             case CONTINUE_PAT_MOD: /* 'c' */
10476                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10477                     if (! (wastedflags & WASTED_C) ) {
10478                         wastedflags |= WASTED_GC;
10479                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10480                         vWARN3(
10481                             RExC_parse + 1,
10482                             "Useless (%sc) - %suse /gc modifier",
10483                             flagsp == &negflags ? "?-" : "?",
10484                             flagsp == &negflags ? "don't " : ""
10485                         );
10486                     }
10487                 }
10488                 break;
10489             case KEEPCOPY_PAT_MOD: /* 'p' */
10490                 if (flagsp == &negflags) {
10491                     if (PASS2)
10492                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10493                 } else {
10494                     *flagsp |= RXf_PMf_KEEPCOPY;
10495                 }
10496                 break;
10497             case '-':
10498                 /* A flag is a default iff it is following a minus, so
10499                  * if there is a minus, it means will be trying to
10500                  * re-specify a default which is an error */
10501                 if (has_use_defaults || flagsp == &negflags) {
10502                     goto fail_modifiers;
10503                 }
10504                 flagsp = &negflags;
10505                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10506                 x_mod_count = 0;
10507                 break;
10508             case ':':
10509             case ')':
10510
10511                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
10512                     negflags |= RXf_PMf_EXTENDED_MORE;
10513                 }
10514                 RExC_flags |= posflags;
10515
10516                 if (negflags & RXf_PMf_EXTENDED) {
10517                     negflags |= RXf_PMf_EXTENDED_MORE;
10518                 }
10519                 RExC_flags &= ~negflags;
10520                 set_regex_charset(&RExC_flags, cs);
10521
10522                 return;
10523             default:
10524               fail_modifiers:
10525                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10526                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10527                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10528                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10529                 NOT_REACHED; /*NOTREACHED*/
10530         }
10531
10532         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10533     }
10534
10535     vFAIL("Sequence (?... not terminated");
10536 }
10537
10538 /*
10539  - reg - regular expression, i.e. main body or parenthesized thing
10540  *
10541  * Caller must absorb opening parenthesis.
10542  *
10543  * Combining parenthesis handling with the base level of regular expression
10544  * is a trifle forced, but the need to tie the tails of the branches to what
10545  * follows makes it hard to avoid.
10546  */
10547 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10548 #ifdef DEBUGGING
10549 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10550 #else
10551 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10552 #endif
10553
10554 PERL_STATIC_INLINE regnode *
10555 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10556                              I32 *flagp,
10557                              char * parse_start,
10558                              char ch
10559                       )
10560 {
10561     regnode *ret;
10562     char* name_start = RExC_parse;
10563     U32 num = 0;
10564     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10565                                             ? REG_RSN_RETURN_NULL
10566                                             : REG_RSN_RETURN_DATA);
10567     GET_RE_DEBUG_FLAGS_DECL;
10568
10569     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10570
10571     if (RExC_parse == name_start || *RExC_parse != ch) {
10572         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10573         vFAIL2("Sequence %.3s... not terminated",parse_start);
10574     }
10575
10576     if (!SIZE_ONLY) {
10577         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10578         RExC_rxi->data->data[num]=(void*)sv_dat;
10579         SvREFCNT_inc_simple_void(sv_dat);
10580     }
10581     RExC_sawback = 1;
10582     ret = reganode(pRExC_state,
10583                    ((! FOLD)
10584                      ? NREF
10585                      : (ASCII_FOLD_RESTRICTED)
10586                        ? NREFFA
10587                        : (AT_LEAST_UNI_SEMANTICS)
10588                          ? NREFFU
10589                          : (LOC)
10590                            ? NREFFL
10591                            : NREFF),
10592                     num);
10593     *flagp |= HASWIDTH;
10594
10595     Set_Node_Offset(ret, parse_start+1);
10596     Set_Node_Cur_Length(ret, parse_start);
10597
10598     nextchar(pRExC_state);
10599     return ret;
10600 }
10601
10602 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10603    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10604    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10605    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10606    NULL, which cannot happen.  */
10607 STATIC regnode *
10608 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10609     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10610      * 2 is like 1, but indicates that nextchar() has been called to advance
10611      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10612      * this flag alerts us to the need to check for that */
10613 {
10614     regnode *ret;               /* Will be the head of the group. */
10615     regnode *br;
10616     regnode *lastbr;
10617     regnode *ender = NULL;
10618     I32 parno = 0;
10619     I32 flags;
10620     U32 oregflags = RExC_flags;
10621     bool have_branch = 0;
10622     bool is_open = 0;
10623     I32 freeze_paren = 0;
10624     I32 after_freeze = 0;
10625     I32 num; /* numeric backreferences */
10626
10627     char * parse_start = RExC_parse; /* MJD */
10628     char * const oregcomp_parse = RExC_parse;
10629
10630     GET_RE_DEBUG_FLAGS_DECL;
10631
10632     PERL_ARGS_ASSERT_REG;
10633     DEBUG_PARSE("reg ");
10634
10635     *flagp = 0;                         /* Tentatively. */
10636
10637     /* Having this true makes it feasible to have a lot fewer tests for the
10638      * parse pointer being in scope.  For example, we can write
10639      *      while(isFOO(*RExC_parse)) RExC_parse++;
10640      * instead of
10641      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10642      */
10643     assert(*RExC_end == '\0');
10644
10645     /* Make an OPEN node, if parenthesized. */
10646     if (paren) {
10647
10648         /* Under /x, space and comments can be gobbled up between the '(' and
10649          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10650          * intervening space, as the sequence is a token, and a token should be
10651          * indivisible */
10652         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
10653
10654         if (RExC_parse >= RExC_end) {
10655             vFAIL("Unmatched (");
10656         }
10657
10658         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
10659             char *start_verb = RExC_parse + 1;
10660             STRLEN verb_len;
10661             char *start_arg = NULL;
10662             unsigned char op = 0;
10663             int arg_required = 0;
10664             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10665
10666             if (has_intervening_patws) {
10667                 RExC_parse++;   /* past the '*' */
10668                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10669             }
10670             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10671                 if ( *RExC_parse == ':' ) {
10672                     start_arg = RExC_parse + 1;
10673                     break;
10674                 }
10675                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10676             }
10677             verb_len = RExC_parse - start_verb;
10678             if ( start_arg ) {
10679                 if (RExC_parse >= RExC_end) {
10680                     goto unterminated_verb_pattern;
10681                 }
10682                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10683                 while ( RExC_parse < RExC_end && *RExC_parse != ')' )
10684                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10685                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10686                   unterminated_verb_pattern:
10687                     vFAIL("Unterminated verb pattern argument");
10688                 if ( RExC_parse == start_arg )
10689                     start_arg = NULL;
10690             } else {
10691                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10692                     vFAIL("Unterminated verb pattern");
10693             }
10694
10695             /* Here, we know that RExC_parse < RExC_end */
10696
10697             switch ( *start_verb ) {
10698             case 'A':  /* (*ACCEPT) */
10699                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10700                     op = ACCEPT;
10701                     internal_argval = RExC_nestroot;
10702                 }
10703                 break;
10704             case 'C':  /* (*COMMIT) */
10705                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10706                     op = COMMIT;
10707                 break;
10708             case 'F':  /* (*FAIL) */
10709                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10710                     op = OPFAIL;
10711                 }
10712                 break;
10713             case ':':  /* (*:NAME) */
10714             case 'M':  /* (*MARK:NAME) */
10715                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10716                     op = MARKPOINT;
10717                     arg_required = 1;
10718                 }
10719                 break;
10720             case 'P':  /* (*PRUNE) */
10721                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10722                     op = PRUNE;
10723                 break;
10724             case 'S':   /* (*SKIP) */
10725                 if ( memEQs(start_verb,verb_len,"SKIP") )
10726                     op = SKIP;
10727                 break;
10728             case 'T':  /* (*THEN) */
10729                 /* [19:06] <TimToady> :: is then */
10730                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10731                     op = CUTGROUP;
10732                     RExC_seen |= REG_CUTGROUP_SEEN;
10733                 }
10734                 break;
10735             }
10736             if ( ! op ) {
10737                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10738                 vFAIL2utf8f(
10739                     "Unknown verb pattern '%" UTF8f "'",
10740                     UTF8fARG(UTF, verb_len, start_verb));
10741             }
10742             if ( arg_required && !start_arg ) {
10743                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
10744                     verb_len, start_verb);
10745             }
10746             if (internal_argval == -1) {
10747                 ret = reganode(pRExC_state, op, 0);
10748             } else {
10749                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
10750             }
10751             RExC_seen |= REG_VERBARG_SEEN;
10752             if ( ! SIZE_ONLY ) {
10753                 if (start_arg) {
10754                     SV *sv = newSVpvn( start_arg,
10755                                        RExC_parse - start_arg);
10756                     ARG(ret) = add_data( pRExC_state,
10757                                          STR_WITH_LEN("S"));
10758                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
10759                     ret->flags = 1;
10760                 } else {
10761                     ret->flags = 0;
10762                 }
10763                 if ( internal_argval != -1 )
10764                     ARG2L_SET(ret, internal_argval);
10765             }
10766             nextchar(pRExC_state);
10767             return ret;
10768         }
10769         else if (*RExC_parse == '?') { /* (?...) */
10770             bool is_logical = 0;
10771             const char * const seqstart = RExC_parse;
10772             const char * endptr;
10773             if (has_intervening_patws) {
10774                 RExC_parse++;
10775                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
10776             }
10777
10778             RExC_parse++;           /* past the '?' */
10779             paren = *RExC_parse;    /* might be a trailing NUL, if not
10780                                        well-formed */
10781             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10782             if (RExC_parse > RExC_end) {
10783                 paren = '\0';
10784             }
10785             ret = NULL;                 /* For look-ahead/behind. */
10786             switch (paren) {
10787
10788             case 'P':   /* (?P...) variants for those used to PCRE/Python */
10789                 paren = *RExC_parse;
10790                 if ( paren == '<') {    /* (?P<...>) named capture */
10791                     RExC_parse++;
10792                     if (RExC_parse >= RExC_end) {
10793                         vFAIL("Sequence (?P<... not terminated");
10794                     }
10795                     goto named_capture;
10796                 }
10797                 else if (paren == '>') {   /* (?P>name) named recursion */
10798                     RExC_parse++;
10799                     if (RExC_parse >= RExC_end) {
10800                         vFAIL("Sequence (?P>... not terminated");
10801                     }
10802                     goto named_recursion;
10803                 }
10804                 else if (paren == '=') {   /* (?P=...)  named backref */
10805                     RExC_parse++;
10806                     return handle_named_backref(pRExC_state, flagp,
10807                                                 parse_start, ')');
10808                 }
10809                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10810                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10811                 vFAIL3("Sequence (%.*s...) not recognized",
10812                                 RExC_parse-seqstart, seqstart);
10813                 NOT_REACHED; /*NOTREACHED*/
10814             case '<':           /* (?<...) */
10815                 if (*RExC_parse == '!')
10816                     paren = ',';
10817                 else if (*RExC_parse != '=')
10818               named_capture:
10819                 {               /* (?<...>) */
10820                     char *name_start;
10821                     SV *svname;
10822                     paren= '>';
10823                 /* FALLTHROUGH */
10824             case '\'':          /* (?'...') */
10825                     name_start = RExC_parse;
10826                     svname = reg_scan_name(pRExC_state,
10827                         SIZE_ONLY    /* reverse test from the others */
10828                         ? REG_RSN_RETURN_NAME
10829                         : REG_RSN_RETURN_NULL);
10830                     if (   RExC_parse == name_start
10831                         || RExC_parse >= RExC_end
10832                         || *RExC_parse != paren)
10833                     {
10834                         vFAIL2("Sequence (?%c... not terminated",
10835                             paren=='>' ? '<' : paren);
10836                     }
10837                     if (SIZE_ONLY) {
10838                         HE *he_str;
10839                         SV *sv_dat = NULL;
10840                         if (!svname) /* shouldn't happen */
10841                             Perl_croak(aTHX_
10842                                 "panic: reg_scan_name returned NULL");
10843                         if (!RExC_paren_names) {
10844                             RExC_paren_names= newHV();
10845                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10846 #ifdef DEBUGGING
10847                             RExC_paren_name_list= newAV();
10848                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10849 #endif
10850                         }
10851                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10852                         if ( he_str )
10853                             sv_dat = HeVAL(he_str);
10854                         if ( ! sv_dat ) {
10855                             /* croak baby croak */
10856                             Perl_croak(aTHX_
10857                                 "panic: paren_name hash element allocation failed");
10858                         } else if ( SvPOK(sv_dat) ) {
10859                             /* (?|...) can mean we have dupes so scan to check
10860                                its already been stored. Maybe a flag indicating
10861                                we are inside such a construct would be useful,
10862                                but the arrays are likely to be quite small, so
10863                                for now we punt -- dmq */
10864                             IV count = SvIV(sv_dat);
10865                             I32 *pv = (I32*)SvPVX(sv_dat);
10866                             IV i;
10867                             for ( i = 0 ; i < count ; i++ ) {
10868                                 if ( pv[i] == RExC_npar ) {
10869                                     count = 0;
10870                                     break;
10871                                 }
10872                             }
10873                             if ( count ) {
10874                                 pv = (I32*)SvGROW(sv_dat,
10875                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10876                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10877                                 pv[count] = RExC_npar;
10878                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10879                             }
10880                         } else {
10881                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10882                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10883                                                                 sizeof(I32));
10884                             SvIOK_on(sv_dat);
10885                             SvIV_set(sv_dat, 1);
10886                         }
10887 #ifdef DEBUGGING
10888                         /* Yes this does cause a memory leak in debugging Perls
10889                          * */
10890                         if (!av_store(RExC_paren_name_list,
10891                                       RExC_npar, SvREFCNT_inc(svname)))
10892                             SvREFCNT_dec_NN(svname);
10893 #endif
10894
10895                         /*sv_dump(sv_dat);*/
10896                     }
10897                     nextchar(pRExC_state);
10898                     paren = 1;
10899                     goto capturing_parens;
10900                 }
10901                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10902                 RExC_in_lookbehind++;
10903                 RExC_parse++;
10904                 if (RExC_parse >= RExC_end) {
10905                     vFAIL("Sequence (?... not terminated");
10906                 }
10907
10908                 /* FALLTHROUGH */
10909             case '=':           /* (?=...) */
10910                 RExC_seen_zerolen++;
10911                 break;
10912             case '!':           /* (?!...) */
10913                 RExC_seen_zerolen++;
10914                 /* check if we're really just a "FAIL" assertion */
10915                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
10916                                         FALSE /* Don't force to /x */ );
10917                 if (*RExC_parse == ')') {
10918                     ret=reganode(pRExC_state, OPFAIL, 0);
10919                     nextchar(pRExC_state);
10920                     return ret;
10921                 }
10922                 break;
10923             case '|':           /* (?|...) */
10924                 /* branch reset, behave like a (?:...) except that
10925                    buffers in alternations share the same numbers */
10926                 paren = ':';
10927                 after_freeze = freeze_paren = RExC_npar;
10928                 break;
10929             case ':':           /* (?:...) */
10930             case '>':           /* (?>...) */
10931                 break;
10932             case '$':           /* (?$...) */
10933             case '@':           /* (?@...) */
10934                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10935                 break;
10936             case '0' :           /* (?0) */
10937             case 'R' :           /* (?R) */
10938                 if (RExC_parse == RExC_end || *RExC_parse != ')')
10939                     FAIL("Sequence (?R) not terminated");
10940                 num = 0;
10941                 RExC_seen |= REG_RECURSE_SEEN;
10942                 *flagp |= POSTPONED;
10943                 goto gen_recurse_regop;
10944                 /*notreached*/
10945             /* named and numeric backreferences */
10946             case '&':            /* (?&NAME) */
10947                 parse_start = RExC_parse - 1;
10948               named_recursion:
10949                 {
10950                     SV *sv_dat = reg_scan_name(pRExC_state,
10951                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10952                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10953                 }
10954                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
10955                     vFAIL("Sequence (?&... not terminated");
10956                 goto gen_recurse_regop;
10957                 /* NOTREACHED */
10958             case '+':
10959                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10960                     RExC_parse++;
10961                     vFAIL("Illegal pattern");
10962                 }
10963                 goto parse_recursion;
10964                 /* NOTREACHED*/
10965             case '-': /* (?-1) */
10966                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10967                     RExC_parse--; /* rewind to let it be handled later */
10968                     goto parse_flags;
10969                 }
10970                 /* FALLTHROUGH */
10971             case '1': case '2': case '3': case '4': /* (?1) */
10972             case '5': case '6': case '7': case '8': case '9':
10973                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
10974               parse_recursion:
10975                 {
10976                     bool is_neg = FALSE;
10977                     UV unum;
10978                     parse_start = RExC_parse - 1; /* MJD */
10979                     if (*RExC_parse == '-') {
10980                         RExC_parse++;
10981                         is_neg = TRUE;
10982                     }
10983                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10984                         && unum <= I32_MAX
10985                     ) {
10986                         num = (I32)unum;
10987                         RExC_parse = (char*)endptr;
10988                     } else
10989                         num = I32_MAX;
10990                     if (is_neg) {
10991                         /* Some limit for num? */
10992                         num = -num;
10993                     }
10994                 }
10995                 if (*RExC_parse!=')')
10996                     vFAIL("Expecting close bracket");
10997
10998               gen_recurse_regop:
10999                 if ( paren == '-' ) {
11000                     /*
11001                     Diagram of capture buffer numbering.
11002                     Top line is the normal capture buffer numbers
11003                     Bottom line is the negative indexing as from
11004                     the X (the (?-2))
11005
11006                     +   1 2    3 4 5 X          6 7
11007                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
11008                     -   5 4    3 2 1 X          x x
11009
11010                     */
11011                     num = RExC_npar + num;
11012                     if (num < 1)  {
11013                         RExC_parse++;
11014                         vFAIL("Reference to nonexistent group");
11015                     }
11016                 } else if ( paren == '+' ) {
11017                     num = RExC_npar + num - 1;
11018                 }
11019                 /* We keep track how many GOSUB items we have produced.
11020                    To start off the ARG2L() of the GOSUB holds its "id",
11021                    which is used later in conjunction with RExC_recurse
11022                    to calculate the offset we need to jump for the GOSUB,
11023                    which it will store in the final representation.
11024                    We have to defer the actual calculation until much later
11025                    as the regop may move.
11026                  */
11027
11028                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
11029                 if (!SIZE_ONLY) {
11030                     if (num > (I32)RExC_rx->nparens) {
11031                         RExC_parse++;
11032                         vFAIL("Reference to nonexistent group");
11033                     }
11034                     RExC_recurse_count++;
11035                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11036                         "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
11037                               22, "|    |", (int)(depth * 2 + 1), "",
11038                               (UV)ARG(ret), (IV)ARG2L(ret)));
11039                 }
11040                 RExC_seen |= REG_RECURSE_SEEN;
11041
11042                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
11043                 Set_Node_Offset(ret, parse_start); /* MJD */
11044
11045                 *flagp |= POSTPONED;
11046                 assert(*RExC_parse == ')');
11047                 nextchar(pRExC_state);
11048                 return ret;
11049
11050             /* NOTREACHED */
11051
11052             case '?':           /* (??...) */
11053                 is_logical = 1;
11054                 if (*RExC_parse != '{') {
11055                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
11056                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11057                     vFAIL2utf8f(
11058                         "Sequence (%" UTF8f "...) not recognized",
11059                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11060                     NOT_REACHED; /*NOTREACHED*/
11061                 }
11062                 *flagp |= POSTPONED;
11063                 paren = '{';
11064                 RExC_parse++;
11065                 /* FALLTHROUGH */
11066             case '{':           /* (?{...}) */
11067             {
11068                 U32 n = 0;
11069                 struct reg_code_block *cb;
11070
11071                 RExC_seen_zerolen++;
11072
11073                 if (   !pRExC_state->code_blocks
11074                     || pRExC_state->code_index
11075                                         >= pRExC_state->code_blocks->count
11076                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11077                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11078                             - RExC_start)
11079                 ) {
11080                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11081                         FAIL("panic: Sequence (?{...}): no code block found\n");
11082                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11083                 }
11084                 /* this is a pre-compiled code block (?{...}) */
11085                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11086                 RExC_parse = RExC_start + cb->end;
11087                 if (!SIZE_ONLY) {
11088                     OP *o = cb->block;
11089                     if (cb->src_regex) {
11090                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11091                         RExC_rxi->data->data[n] =
11092                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
11093                         RExC_rxi->data->data[n+1] = (void*)o;
11094                     }
11095                     else {
11096                         n = add_data(pRExC_state,
11097                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11098                         RExC_rxi->data->data[n] = (void*)o;
11099                     }
11100                 }
11101                 pRExC_state->code_index++;
11102                 nextchar(pRExC_state);
11103
11104                 if (is_logical) {
11105                     regnode *eval;
11106                     ret = reg_node(pRExC_state, LOGICAL);
11107
11108                     eval = reg2Lanode(pRExC_state, EVAL,
11109                                        n,
11110
11111                                        /* for later propagation into (??{})
11112                                         * return value */
11113                                        RExC_flags & RXf_PMf_COMPILETIME
11114                                       );
11115                     if (!SIZE_ONLY) {
11116                         ret->flags = 2;
11117                     }
11118                     REGTAIL(pRExC_state, ret, eval);
11119                     /* deal with the length of this later - MJD */
11120                     return ret;
11121                 }
11122                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11123                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
11124                 Set_Node_Offset(ret, parse_start);
11125                 return ret;
11126             }
11127             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11128             {
11129                 int is_define= 0;
11130                 const int DEFINE_len = sizeof("DEFINE") - 1;
11131                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
11132                     if (   RExC_parse < RExC_end - 1
11133                         && (   RExC_parse[1] == '='
11134                             || RExC_parse[1] == '!'
11135                             || RExC_parse[1] == '<'
11136                             || RExC_parse[1] == '{')
11137                     ) { /* Lookahead or eval. */
11138                         I32 flag;
11139                         regnode *tail;
11140
11141                         ret = reg_node(pRExC_state, LOGICAL);
11142                         if (!SIZE_ONLY)
11143                             ret->flags = 1;
11144
11145                         tail = reg(pRExC_state, 1, &flag, depth+1);
11146                         if (flag & (RESTART_PASS1|NEED_UTF8)) {
11147                             *flagp = flag & (RESTART_PASS1|NEED_UTF8);
11148                             return NULL;
11149                         }
11150                         REGTAIL(pRExC_state, ret, tail);
11151                         goto insert_if;
11152                     }
11153                     /* Fall through to ‘Unknown switch condition’ at the
11154                        end of the if/else chain. */
11155                 }
11156                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11157                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11158                 {
11159                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11160                     char *name_start= RExC_parse++;
11161                     U32 num = 0;
11162                     SV *sv_dat=reg_scan_name(pRExC_state,
11163                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11164                     if (   RExC_parse == name_start
11165                         || RExC_parse >= RExC_end
11166                         || *RExC_parse != ch)
11167                     {
11168                         vFAIL2("Sequence (?(%c... not terminated",
11169                             (ch == '>' ? '<' : ch));
11170                     }
11171                     RExC_parse++;
11172                     if (!SIZE_ONLY) {
11173                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11174                         RExC_rxi->data->data[num]=(void*)sv_dat;
11175                         SvREFCNT_inc_simple_void(sv_dat);
11176                     }
11177                     ret = reganode(pRExC_state,NGROUPP,num);
11178                     goto insert_if_check_paren;
11179                 }
11180                 else if (RExC_end - RExC_parse >= DEFINE_len
11181                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
11182                 {
11183                     ret = reganode(pRExC_state,DEFINEP,0);
11184                     RExC_parse += DEFINE_len;
11185                     is_define = 1;
11186                     goto insert_if_check_paren;
11187                 }
11188                 else if (RExC_parse[0] == 'R') {
11189                     RExC_parse++;
11190                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11191                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11192                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11193                      */
11194                     parno = 0;
11195                     if (RExC_parse[0] == '0') {
11196                         parno = 1;
11197                         RExC_parse++;
11198                     }
11199                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11200                         UV uv;
11201                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11202                             && uv <= I32_MAX
11203                         ) {
11204                             parno = (I32)uv + 1;
11205                             RExC_parse = (char*)endptr;
11206                         }
11207                         /* else "Switch condition not recognized" below */
11208                     } else if (RExC_parse[0] == '&') {
11209                         SV *sv_dat;
11210                         RExC_parse++;
11211                         sv_dat = reg_scan_name(pRExC_state,
11212                             SIZE_ONLY
11213                             ? REG_RSN_RETURN_NULL
11214                             : REG_RSN_RETURN_DATA);
11215
11216                         /* we should only have a false sv_dat when
11217                          * SIZE_ONLY is true, and we always have false
11218                          * sv_dat when SIZE_ONLY is true.
11219                          * reg_scan_name() will VFAIL() if the name is
11220                          * unknown when SIZE_ONLY is false, and otherwise
11221                          * will return something, and when SIZE_ONLY is
11222                          * true, reg_scan_name() just parses the string,
11223                          * and doesnt return anything. (in theory) */
11224                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
11225
11226                         if (sv_dat)
11227                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11228                     }
11229                     ret = reganode(pRExC_state,INSUBP,parno);
11230                     goto insert_if_check_paren;
11231                 }
11232                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11233                     /* (?(1)...) */
11234                     char c;
11235                     UV uv;
11236                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11237                         && uv <= I32_MAX
11238                     ) {
11239                         parno = (I32)uv;
11240                         RExC_parse = (char*)endptr;
11241                     }
11242                     else {
11243                         vFAIL("panic: grok_atoUV returned FALSE");
11244                     }
11245                     ret = reganode(pRExC_state, GROUPP, parno);
11246
11247                  insert_if_check_paren:
11248                     if (UCHARAT(RExC_parse) != ')') {
11249                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11250                         vFAIL("Switch condition not recognized");
11251                     }
11252                     nextchar(pRExC_state);
11253                   insert_if:
11254                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11255                     br = regbranch(pRExC_state, &flags, 1,depth+1);
11256                     if (br == NULL) {
11257                         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11258                             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11259                             return NULL;
11260                         }
11261                         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11262                               (UV) flags);
11263                     } else
11264                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11265                                                           LONGJMP, 0));
11266                     c = UCHARAT(RExC_parse);
11267                     nextchar(pRExC_state);
11268                     if (flags&HASWIDTH)
11269                         *flagp |= HASWIDTH;
11270                     if (c == '|') {
11271                         if (is_define)
11272                             vFAIL("(?(DEFINE)....) does not allow branches");
11273
11274                         /* Fake one for optimizer.  */
11275                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11276
11277                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
11278                             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11279                                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11280                                 return NULL;
11281                             }
11282                             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11283                                   (UV) flags);
11284                         }
11285                         REGTAIL(pRExC_state, ret, lastbr);
11286                         if (flags&HASWIDTH)
11287                             *flagp |= HASWIDTH;
11288                         c = UCHARAT(RExC_parse);
11289                         nextchar(pRExC_state);
11290                     }
11291                     else
11292                         lastbr = NULL;
11293                     if (c != ')') {
11294                         if (RExC_parse >= RExC_end)
11295                             vFAIL("Switch (?(condition)... not terminated");
11296                         else
11297                             vFAIL("Switch (?(condition)... contains too many branches");
11298                     }
11299                     ender = reg_node(pRExC_state, TAIL);
11300                     REGTAIL(pRExC_state, br, ender);
11301                     if (lastbr) {
11302                         REGTAIL(pRExC_state, lastbr, ender);
11303                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11304                     }
11305                     else
11306                         REGTAIL(pRExC_state, ret, ender);
11307                     RExC_size++; /* XXX WHY do we need this?!!
11308                                     For large programs it seems to be required
11309                                     but I can't figure out why. -- dmq*/
11310                     return ret;
11311                 }
11312                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11313                 vFAIL("Unknown switch condition (?(...))");
11314             }
11315             case '[':           /* (?[ ... ]) */
11316                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
11317                                          oregcomp_parse);
11318             case 0: /* A NUL */
11319                 RExC_parse--; /* for vFAIL to print correctly */
11320                 vFAIL("Sequence (? incomplete");
11321                 break;
11322             default: /* e.g., (?i) */
11323                 RExC_parse = (char *) seqstart + 1;
11324               parse_flags:
11325                 parse_lparen_question_flags(pRExC_state);
11326                 if (UCHARAT(RExC_parse) != ':') {
11327                     if (RExC_parse < RExC_end)
11328                         nextchar(pRExC_state);
11329                     *flagp = TRYAGAIN;
11330                     return NULL;
11331                 }
11332                 paren = ':';
11333                 nextchar(pRExC_state);
11334                 ret = NULL;
11335                 goto parse_rest;
11336             } /* end switch */
11337         }
11338         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11339           capturing_parens:
11340             parno = RExC_npar;
11341             RExC_npar++;
11342
11343             ret = reganode(pRExC_state, OPEN, parno);
11344             if (!SIZE_ONLY ){
11345                 if (!RExC_nestroot)
11346                     RExC_nestroot = parno;
11347                 if (RExC_open_parens && !RExC_open_parens[parno])
11348                 {
11349                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11350                         "%*s%*s Setting open paren #%" IVdf " to %d\n",
11351                         22, "|    |", (int)(depth * 2 + 1), "",
11352                         (IV)parno, REG_NODE_NUM(ret)));
11353                     RExC_open_parens[parno]= ret;
11354                 }
11355             }
11356             Set_Node_Length(ret, 1); /* MJD */
11357             Set_Node_Offset(ret, RExC_parse); /* MJD */
11358             is_open = 1;
11359         } else {
11360             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11361             paren = ':';
11362             ret = NULL;
11363         }
11364     }
11365     else                        /* ! paren */
11366         ret = NULL;
11367
11368    parse_rest:
11369     /* Pick up the branches, linking them together. */
11370     parse_start = RExC_parse;   /* MJD */
11371     br = regbranch(pRExC_state, &flags, 1,depth+1);
11372
11373     /*     branch_len = (paren != 0); */
11374
11375     if (br == NULL) {
11376         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11377             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11378             return NULL;
11379         }
11380         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11381     }
11382     if (*RExC_parse == '|') {
11383         if (!SIZE_ONLY && RExC_extralen) {
11384             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11385         }
11386         else {                  /* MJD */
11387             reginsert(pRExC_state, BRANCH, br, depth+1);
11388             Set_Node_Length(br, paren != 0);
11389             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11390         }
11391         have_branch = 1;
11392         if (SIZE_ONLY)
11393             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11394     }
11395     else if (paren == ':') {
11396         *flagp |= flags&SIMPLE;
11397     }
11398     if (is_open) {                              /* Starts with OPEN. */
11399         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11400     }
11401     else if (paren != '?')              /* Not Conditional */
11402         ret = br;
11403     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11404     lastbr = br;
11405     while (*RExC_parse == '|') {
11406         if (!SIZE_ONLY && RExC_extralen) {
11407             ender = reganode(pRExC_state, LONGJMP,0);
11408
11409             /* Append to the previous. */
11410             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11411         }
11412         if (SIZE_ONLY)
11413             RExC_extralen += 2;         /* Account for LONGJMP. */
11414         nextchar(pRExC_state);
11415         if (freeze_paren) {
11416             if (RExC_npar > after_freeze)
11417                 after_freeze = RExC_npar;
11418             RExC_npar = freeze_paren;
11419         }
11420         br = regbranch(pRExC_state, &flags, 0, depth+1);
11421
11422         if (br == NULL) {
11423             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11424                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11425                 return NULL;
11426             }
11427             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11428         }
11429         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11430         lastbr = br;
11431         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11432     }
11433
11434     if (have_branch || paren != ':') {
11435         /* Make a closing node, and hook it on the end. */
11436         switch (paren) {
11437         case ':':
11438             ender = reg_node(pRExC_state, TAIL);
11439             break;
11440         case 1: case 2:
11441             ender = reganode(pRExC_state, CLOSE, parno);
11442             if ( RExC_close_parens ) {
11443                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11444                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
11445                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11446                 RExC_close_parens[parno]= ender;
11447                 if (RExC_nestroot == parno)
11448                     RExC_nestroot = 0;
11449             }
11450             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11451             Set_Node_Length(ender,1); /* MJD */
11452             break;
11453         case '<':
11454         case ',':
11455         case '=':
11456         case '!':
11457             *flagp &= ~HASWIDTH;
11458             /* FALLTHROUGH */
11459         case '>':
11460             ender = reg_node(pRExC_state, SUCCEED);
11461             break;
11462         case 0:
11463             ender = reg_node(pRExC_state, END);
11464             if (!SIZE_ONLY) {
11465                 assert(!RExC_end_op); /* there can only be one! */
11466                 RExC_end_op = ender;
11467                 if (RExC_close_parens) {
11468                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11469                         "%*s%*s Setting close paren #0 (END) to %d\n",
11470                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11471
11472                     RExC_close_parens[0]= ender;
11473                 }
11474             }
11475             break;
11476         }
11477         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11478             DEBUG_PARSE_MSG("lsbr");
11479             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11480             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11481             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11482                           SvPV_nolen_const(RExC_mysv1),
11483                           (IV)REG_NODE_NUM(lastbr),
11484                           SvPV_nolen_const(RExC_mysv2),
11485                           (IV)REG_NODE_NUM(ender),
11486                           (IV)(ender - lastbr)
11487             );
11488         });
11489         REGTAIL(pRExC_state, lastbr, ender);
11490
11491         if (have_branch && !SIZE_ONLY) {
11492             char is_nothing= 1;
11493             if (depth==1)
11494                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11495
11496             /* Hook the tails of the branches to the closing node. */
11497             for (br = ret; br; br = regnext(br)) {
11498                 const U8 op = PL_regkind[OP(br)];
11499                 if (op == BRANCH) {
11500                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11501                     if ( OP(NEXTOPER(br)) != NOTHING
11502                          || regnext(NEXTOPER(br)) != ender)
11503                         is_nothing= 0;
11504                 }
11505                 else if (op == BRANCHJ) {
11506                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11507                     /* for now we always disable this optimisation * /
11508                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11509                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11510                     */
11511                         is_nothing= 0;
11512                 }
11513             }
11514             if (is_nothing) {
11515                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11516                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11517                     DEBUG_PARSE_MSG("NADA");
11518                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11519                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11520                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11521                                   SvPV_nolen_const(RExC_mysv1),
11522                                   (IV)REG_NODE_NUM(ret),
11523                                   SvPV_nolen_const(RExC_mysv2),
11524                                   (IV)REG_NODE_NUM(ender),
11525                                   (IV)(ender - ret)
11526                     );
11527                 });
11528                 OP(br)= NOTHING;
11529                 if (OP(ender) == TAIL) {
11530                     NEXT_OFF(br)= 0;
11531                     RExC_emit= br + 1;
11532                 } else {
11533                     regnode *opt;
11534                     for ( opt= br + 1; opt < ender ; opt++ )
11535                         OP(opt)= OPTIMIZED;
11536                     NEXT_OFF(br)= ender - br;
11537                 }
11538             }
11539         }
11540     }
11541
11542     {
11543         const char *p;
11544         static const char parens[] = "=!<,>";
11545
11546         if (paren && (p = strchr(parens, paren))) {
11547             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11548             int flag = (p - parens) > 1;
11549
11550             if (paren == '>')
11551                 node = SUSPEND, flag = 0;
11552             reginsert(pRExC_state, node,ret, depth+1);
11553             Set_Node_Cur_Length(ret, parse_start);
11554             Set_Node_Offset(ret, parse_start + 1);
11555             ret->flags = flag;
11556             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11557         }
11558     }
11559
11560     /* Check for proper termination. */
11561     if (paren) {
11562         /* restore original flags, but keep (?p) and, if we've changed from /d
11563          * rules to /u, keep the /u */
11564         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11565         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11566             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11567         }
11568         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11569             RExC_parse = oregcomp_parse;
11570             vFAIL("Unmatched (");
11571         }
11572         nextchar(pRExC_state);
11573     }
11574     else if (!paren && RExC_parse < RExC_end) {
11575         if (*RExC_parse == ')') {
11576             RExC_parse++;
11577             vFAIL("Unmatched )");
11578         }
11579         else
11580             FAIL("Junk on end of regexp");      /* "Can't happen". */
11581         NOT_REACHED; /* NOTREACHED */
11582     }
11583
11584     if (RExC_in_lookbehind) {
11585         RExC_in_lookbehind--;
11586     }
11587     if (after_freeze > RExC_npar)
11588         RExC_npar = after_freeze;
11589     return(ret);
11590 }
11591
11592 /*
11593  - regbranch - one alternative of an | operator
11594  *
11595  * Implements the concatenation operator.
11596  *
11597  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11598  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11599  */
11600 STATIC regnode *
11601 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11602 {
11603     regnode *ret;
11604     regnode *chain = NULL;
11605     regnode *latest;
11606     I32 flags = 0, c = 0;
11607     GET_RE_DEBUG_FLAGS_DECL;
11608
11609     PERL_ARGS_ASSERT_REGBRANCH;
11610
11611     DEBUG_PARSE("brnc");
11612
11613     if (first)
11614         ret = NULL;
11615     else {
11616         if (!SIZE_ONLY && RExC_extralen)
11617             ret = reganode(pRExC_state, BRANCHJ,0);
11618         else {
11619             ret = reg_node(pRExC_state, BRANCH);
11620             Set_Node_Length(ret, 1);
11621         }
11622     }
11623
11624     if (!first && SIZE_ONLY)
11625         RExC_extralen += 1;                     /* BRANCHJ */
11626
11627     *flagp = WORST;                     /* Tentatively. */
11628
11629     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11630                             FALSE /* Don't force to /x */ );
11631     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11632         flags &= ~TRYAGAIN;
11633         latest = regpiece(pRExC_state, &flags,depth+1);
11634         if (latest == NULL) {
11635             if (flags & TRYAGAIN)
11636                 continue;
11637             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11638                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11639                 return NULL;
11640             }
11641             FAIL2("panic: regpiece returned NULL, flags=%#" UVxf, (UV) flags);
11642         }
11643         else if (ret == NULL)
11644             ret = latest;
11645         *flagp |= flags&(HASWIDTH|POSTPONED);
11646         if (chain == NULL)      /* First piece. */
11647             *flagp |= flags&SPSTART;
11648         else {
11649             /* FIXME adding one for every branch after the first is probably
11650              * excessive now we have TRIE support. (hv) */
11651             MARK_NAUGHTY(1);
11652             REGTAIL(pRExC_state, chain, latest);
11653         }
11654         chain = latest;
11655         c++;
11656     }
11657     if (chain == NULL) {        /* Loop ran zero times. */
11658         chain = reg_node(pRExC_state, NOTHING);
11659         if (ret == NULL)
11660             ret = chain;
11661     }
11662     if (c == 1) {
11663         *flagp |= flags&SIMPLE;
11664     }
11665
11666     return ret;
11667 }
11668
11669 /*
11670  - regpiece - something followed by possible quantifier * + ? {n,m}
11671  *
11672  * Note that the branching code sequences used for ? and the general cases
11673  * of * and + are somewhat optimized:  they use the same NOTHING node as
11674  * both the endmarker for their branch list and the body of the last branch.
11675  * It might seem that this node could be dispensed with entirely, but the
11676  * endmarker role is not redundant.
11677  *
11678  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11679  * TRYAGAIN.
11680  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11681  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11682  */
11683 STATIC regnode *
11684 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11685 {
11686     regnode *ret;
11687     char op;
11688     char *next;
11689     I32 flags;
11690     const char * const origparse = RExC_parse;
11691     I32 min;
11692     I32 max = REG_INFTY;
11693 #ifdef RE_TRACK_PATTERN_OFFSETS
11694     char *parse_start;
11695 #endif
11696     const char *maxpos = NULL;
11697     UV uv;
11698
11699     /* Save the original in case we change the emitted regop to a FAIL. */
11700     regnode * const orig_emit = RExC_emit;
11701
11702     GET_RE_DEBUG_FLAGS_DECL;
11703
11704     PERL_ARGS_ASSERT_REGPIECE;
11705
11706     DEBUG_PARSE("piec");
11707
11708     ret = regatom(pRExC_state, &flags,depth+1);
11709     if (ret == NULL) {
11710         if (flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8))
11711             *flagp |= flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8);
11712         else
11713             FAIL2("panic: regatom returned NULL, flags=%#" UVxf, (UV) flags);
11714         return(NULL);
11715     }
11716
11717     op = *RExC_parse;
11718
11719     if (op == '{' && regcurly(RExC_parse)) {
11720         maxpos = NULL;
11721 #ifdef RE_TRACK_PATTERN_OFFSETS
11722         parse_start = RExC_parse; /* MJD */
11723 #endif
11724         next = RExC_parse + 1;
11725         while (isDIGIT(*next) || *next == ',') {
11726             if (*next == ',') {
11727                 if (maxpos)
11728                     break;
11729                 else
11730                     maxpos = next;
11731             }
11732             next++;
11733         }
11734         if (*next == '}') {             /* got one */
11735             const char* endptr;
11736             if (!maxpos)
11737                 maxpos = next;
11738             RExC_parse++;
11739             if (isDIGIT(*RExC_parse)) {
11740                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
11741                     vFAIL("Invalid quantifier in {,}");
11742                 if (uv >= REG_INFTY)
11743                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11744                 min = (I32)uv;
11745             } else {
11746                 min = 0;
11747             }
11748             if (*maxpos == ',')
11749                 maxpos++;
11750             else
11751                 maxpos = RExC_parse;
11752             if (isDIGIT(*maxpos)) {
11753                 if (!grok_atoUV(maxpos, &uv, &endptr))
11754                     vFAIL("Invalid quantifier in {,}");
11755                 if (uv >= REG_INFTY)
11756                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11757                 max = (I32)uv;
11758             } else {
11759                 max = REG_INFTY;                /* meaning "infinity" */
11760             }
11761             RExC_parse = next;
11762             nextchar(pRExC_state);
11763             if (max < min) {    /* If can't match, warn and optimize to fail
11764                                    unconditionally */
11765                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
11766                 if (PASS2) {
11767                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
11768                     NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
11769                 }
11770                 return ret;
11771             }
11772             else if (min == max && *RExC_parse == '?')
11773             {
11774                 if (PASS2) {
11775                     ckWARN2reg(RExC_parse + 1,
11776                                "Useless use of greediness modifier '%c'",
11777                                *RExC_parse);
11778                 }
11779             }
11780
11781           do_curly:
11782             if ((flags&SIMPLE)) {
11783                 if (min == 0 && max == REG_INFTY) {
11784                     reginsert(pRExC_state, STAR, ret, depth+1);
11785                     MARK_NAUGHTY(4);
11786                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11787                     goto nest_check;
11788                 }
11789                 if (min == 1 && max == REG_INFTY) {
11790                     reginsert(pRExC_state, PLUS, ret, depth+1);
11791                     MARK_NAUGHTY(3);
11792                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11793                     goto nest_check;
11794                 }
11795                 MARK_NAUGHTY_EXP(2, 2);
11796                 reginsert(pRExC_state, CURLY, ret, depth+1);
11797                 Set_Node_Offset(ret, parse_start+1); /* MJD */
11798                 Set_Node_Cur_Length(ret, parse_start);
11799             }
11800             else {
11801                 regnode * const w = reg_node(pRExC_state, WHILEM);
11802
11803                 w->flags = 0;
11804                 REGTAIL(pRExC_state, ret, w);
11805                 if (!SIZE_ONLY && RExC_extralen) {
11806                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
11807                     reginsert(pRExC_state, NOTHING,ret, depth+1);
11808                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
11809                 }
11810                 reginsert(pRExC_state, CURLYX,ret, depth+1);
11811                                 /* MJD hk */
11812                 Set_Node_Offset(ret, parse_start+1);
11813                 Set_Node_Length(ret,
11814                                 op == '{' ? (RExC_parse - parse_start) : 1);
11815
11816                 if (!SIZE_ONLY && RExC_extralen)
11817                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
11818                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
11819                 if (SIZE_ONLY)
11820                     RExC_whilem_seen++, RExC_extralen += 3;
11821                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
11822             }
11823             ret->flags = 0;
11824
11825             if (min > 0)
11826                 *flagp = WORST;
11827             if (max > 0)
11828                 *flagp |= HASWIDTH;
11829             if (!SIZE_ONLY) {
11830                 ARG1_SET(ret, (U16)min);
11831                 ARG2_SET(ret, (U16)max);
11832             }
11833             if (max == REG_INFTY)
11834                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11835
11836             goto nest_check;
11837         }
11838     }
11839
11840     if (!ISMULT1(op)) {
11841         *flagp = flags;
11842         return(ret);
11843     }
11844
11845 #if 0                           /* Now runtime fix should be reliable. */
11846
11847     /* if this is reinstated, don't forget to put this back into perldiag:
11848
11849             =item Regexp *+ operand could be empty at {#} in regex m/%s/
11850
11851            (F) The part of the regexp subject to either the * or + quantifier
11852            could match an empty string. The {#} shows in the regular
11853            expression about where the problem was discovered.
11854
11855     */
11856
11857     if (!(flags&HASWIDTH) && op != '?')
11858       vFAIL("Regexp *+ operand could be empty");
11859 #endif
11860
11861 #ifdef RE_TRACK_PATTERN_OFFSETS
11862     parse_start = RExC_parse;
11863 #endif
11864     nextchar(pRExC_state);
11865
11866     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
11867
11868     if (op == '*') {
11869         min = 0;
11870         goto do_curly;
11871     }
11872     else if (op == '+') {
11873         min = 1;
11874         goto do_curly;
11875     }
11876     else if (op == '?') {
11877         min = 0; max = 1;
11878         goto do_curly;
11879     }
11880   nest_check:
11881     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
11882         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11883         ckWARN2reg(RExC_parse,
11884                    "%" UTF8f " matches null string many times",
11885                    UTF8fARG(UTF, (RExC_parse >= origparse
11886                                  ? RExC_parse - origparse
11887                                  : 0),
11888                    origparse));
11889         (void)ReREFCNT_inc(RExC_rx_sv);
11890     }
11891
11892     if (*RExC_parse == '?') {
11893         nextchar(pRExC_state);
11894         reginsert(pRExC_state, MINMOD, ret, depth+1);
11895         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11896     }
11897     else if (*RExC_parse == '+') {
11898         regnode *ender;
11899         nextchar(pRExC_state);
11900         ender = reg_node(pRExC_state, SUCCEED);
11901         REGTAIL(pRExC_state, ret, ender);
11902         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11903         ender = reg_node(pRExC_state, TAIL);
11904         REGTAIL(pRExC_state, ret, ender);
11905     }
11906
11907     if (ISMULT2(RExC_parse)) {
11908         RExC_parse++;
11909         vFAIL("Nested quantifiers");
11910     }
11911
11912     return(ret);
11913 }
11914
11915 STATIC bool
11916 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11917                 regnode ** node_p,
11918                 UV * code_point_p,
11919                 int * cp_count,
11920                 I32 * flagp,
11921                 const bool strict,
11922                 const U32 depth
11923     )
11924 {
11925  /* This routine teases apart the various meanings of \N and returns
11926   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11927   * in the current context.
11928   *
11929   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11930   *
11931   * If <code_point_p> is not NULL, the context is expecting the result to be a
11932   * single code point.  If this \N instance turns out to a single code point,
11933   * the function returns TRUE and sets *code_point_p to that code point.
11934   *
11935   * If <node_p> is not NULL, the context is expecting the result to be one of
11936   * the things representable by a regnode.  If this \N instance turns out to be
11937   * one such, the function generates the regnode, returns TRUE and sets *node_p
11938   * to point to that regnode.
11939   *
11940   * If this instance of \N isn't legal in any context, this function will
11941   * generate a fatal error and not return.
11942   *
11943   * On input, RExC_parse should point to the first char following the \N at the
11944   * time of the call.  On successful return, RExC_parse will have been updated
11945   * to point to just after the sequence identified by this routine.  Also
11946   * *flagp has been updated as needed.
11947   *
11948   * When there is some problem with the current context and this \N instance,
11949   * the function returns FALSE, without advancing RExC_parse, nor setting
11950   * *node_p, nor *code_point_p, nor *flagp.
11951   *
11952   * If <cp_count> is not NULL, the caller wants to know the length (in code
11953   * points) that this \N sequence matches.  This is set even if the function
11954   * returns FALSE, as detailed below.
11955   *
11956   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11957   *
11958   * Probably the most common case is for the \N to specify a single code point.
11959   * *cp_count will be set to 1, and *code_point_p will be set to that code
11960   * point.
11961   *
11962   * Another possibility is for the input to be an empty \N{}, which for
11963   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11964   * will be set to a generated NOTHING node.
11965   *
11966   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11967   * set to 0. *node_p will be set to a generated REG_ANY node.
11968   *
11969   * The fourth possibility is that \N resolves to a sequence of more than one
11970   * code points.  *cp_count will be set to the number of code points in the
11971   * sequence. *node_p * will be set to a generated node returned by this
11972   * function calling S_reg().
11973   *
11974   * The final possibility is that it is premature to be calling this function;
11975   * that pass1 needs to be restarted.  This can happen when this changes from
11976   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
11977   * latter occurs only when the fourth possibility would otherwise be in
11978   * effect, and is because one of those code points requires the pattern to be
11979   * recompiled as UTF-8.  The function returns FALSE, and sets the
11980   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
11981   * happens, the caller needs to desist from continuing parsing, and return
11982   * this information to its caller.  This is not set for when there is only one
11983   * code point, as this can be called as part of an ANYOF node, and they can
11984   * store above-Latin1 code points without the pattern having to be in UTF-8.
11985   *
11986   * For non-single-quoted regexes, the tokenizer has resolved character and
11987   * sequence names inside \N{...} into their Unicode values, normalizing the
11988   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11989   * hex-represented code points in the sequence.  This is done there because
11990   * the names can vary based on what charnames pragma is in scope at the time,
11991   * so we need a way to take a snapshot of what they resolve to at the time of
11992   * the original parse. [perl #56444].
11993   *
11994   * That parsing is skipped for single-quoted regexes, so we may here get
11995   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11996   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11997   * is legal and handled here.  The code point is Unicode, and has to be
11998   * translated into the native character set for non-ASCII platforms.
11999   */
12000
12001     char * endbrace;    /* points to '}' following the name */
12002     char *endchar;      /* Points to '.' or '}' ending cur char in the input
12003                            stream */
12004     char* p = RExC_parse; /* Temporary */
12005
12006     GET_RE_DEBUG_FLAGS_DECL;
12007
12008     PERL_ARGS_ASSERT_GROK_BSLASH_N;
12009
12010     GET_RE_DEBUG_FLAGS;
12011
12012     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
12013     assert(! (node_p && cp_count));               /* At most 1 should be set */
12014
12015     if (cp_count) {     /* Initialize return for the most common case */
12016         *cp_count = 1;
12017     }
12018
12019     /* The [^\n] meaning of \N ignores spaces and comments under the /x
12020      * modifier.  The other meanings do not, so use a temporary until we find
12021      * out which we are being called with */
12022     skip_to_be_ignored_text(pRExC_state, &p,
12023                             FALSE /* Don't force to /x */ );
12024
12025     /* Disambiguate between \N meaning a named character versus \N meaning
12026      * [^\n].  The latter is assumed when the {...} following the \N is a legal
12027      * quantifier, or there is no '{' at all */
12028     if (*p != '{' || regcurly(p)) {
12029         RExC_parse = p;
12030         if (cp_count) {
12031             *cp_count = -1;
12032         }
12033
12034         if (! node_p) {
12035             return FALSE;
12036         }
12037
12038         *node_p = reg_node(pRExC_state, REG_ANY);
12039         *flagp |= HASWIDTH|SIMPLE;
12040         MARK_NAUGHTY(1);
12041         Set_Node_Length(*node_p, 1); /* MJD */
12042         return TRUE;
12043     }
12044
12045     /* Here, we have decided it should be a named character or sequence */
12046
12047     /* The test above made sure that the next real character is a '{', but
12048      * under the /x modifier, it could be separated by space (or a comment and
12049      * \n) and this is not allowed (for consistency with \x{...} and the
12050      * tokenizer handling of \N{NAME}). */
12051     if (*RExC_parse != '{') {
12052         vFAIL("Missing braces on \\N{}");
12053     }
12054
12055     RExC_parse++;       /* Skip past the '{' */
12056
12057     endbrace = strchr(RExC_parse, '}');
12058     if (! endbrace) { /* no trailing brace */
12059         vFAIL2("Missing right brace on \\%c{}", 'N');
12060     }
12061     else if(!(endbrace == RExC_parse            /* nothing between the {} */
12062               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
12063                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
12064                                                        error msg) */
12065     {
12066         RExC_parse = endbrace;  /* position msg's '<--HERE' */
12067         vFAIL("\\N{NAME} must be resolved by the lexer");
12068     }
12069
12070     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
12071                                         semantics */
12072
12073     if (endbrace == RExC_parse) {   /* empty: \N{} */
12074         if (strict) {
12075             RExC_parse++;   /* Position after the "}" */
12076             vFAIL("Zero length \\N{}");
12077         }
12078         if (cp_count) {
12079             *cp_count = 0;
12080         }
12081         nextchar(pRExC_state);
12082         if (! node_p) {
12083             return FALSE;
12084         }
12085
12086         *node_p = reg_node(pRExC_state,NOTHING);
12087         return TRUE;
12088     }
12089
12090     RExC_parse += 2;    /* Skip past the 'U+' */
12091
12092     /* Because toke.c has generated a special construct for us guaranteed not
12093      * to have NULs, we can use a str function */
12094     endchar = RExC_parse + strcspn(RExC_parse, ".}");
12095
12096     /* Code points are separated by dots.  If none, there is only one code
12097      * point, and is terminated by the brace */
12098
12099     if (endchar >= endbrace) {
12100         STRLEN length_of_hex;
12101         I32 grok_hex_flags;
12102
12103         /* Here, exactly one code point.  If that isn't what is wanted, fail */
12104         if (! code_point_p) {
12105             RExC_parse = p;
12106             return FALSE;
12107         }
12108
12109         /* Convert code point from hex */
12110         length_of_hex = (STRLEN)(endchar - RExC_parse);
12111         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
12112                            | PERL_SCAN_DISALLOW_PREFIX
12113
12114                              /* No errors in the first pass (See [perl
12115                               * #122671].)  We let the code below find the
12116                               * errors when there are multiple chars. */
12117                            | ((SIZE_ONLY)
12118                               ? PERL_SCAN_SILENT_ILLDIGIT
12119                               : 0);
12120
12121         /* This routine is the one place where both single- and double-quotish
12122          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
12123          * must be converted to native. */
12124         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
12125                                          &length_of_hex,
12126                                          &grok_hex_flags,
12127                                          NULL));
12128
12129         /* The tokenizer should have guaranteed validity, but it's possible to
12130          * bypass it by using single quoting, so check.  Don't do the check
12131          * here when there are multiple chars; we do it below anyway. */
12132         if (length_of_hex == 0
12133             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
12134         {
12135             RExC_parse += length_of_hex;        /* Includes all the valid */
12136             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
12137                             ? UTF8SKIP(RExC_parse)
12138                             : 1;
12139             /* Guard against malformed utf8 */
12140             if (RExC_parse >= endchar) {
12141                 RExC_parse = endchar;
12142             }
12143             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12144         }
12145
12146         RExC_parse = endbrace + 1;
12147         return TRUE;
12148     }
12149     else {  /* Is a multiple character sequence */
12150         SV * substitute_parse;
12151         STRLEN len;
12152         char *orig_end = RExC_end;
12153         char *save_start = RExC_start;
12154         I32 flags;
12155
12156         /* Count the code points, if desired, in the sequence */
12157         if (cp_count) {
12158             *cp_count = 0;
12159             while (RExC_parse < endbrace) {
12160                 /* Point to the beginning of the next character in the sequence. */
12161                 RExC_parse = endchar + 1;
12162                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
12163                 (*cp_count)++;
12164             }
12165         }
12166
12167         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12168          * But don't backup up the pointer if the caller want to know how many
12169          * code points there are (they can then handle things) */
12170         if (! node_p) {
12171             if (! cp_count) {
12172                 RExC_parse = p;
12173             }
12174             return FALSE;
12175         }
12176
12177         /* What is done here is to convert this to a sub-pattern of the form
12178          * \x{char1}\x{char2}...  and then call reg recursively to parse it
12179          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
12180          * while not having to worry about special handling that some code
12181          * points may have. */
12182
12183         substitute_parse = newSVpvs("?:");
12184
12185         while (RExC_parse < endbrace) {
12186
12187             /* Convert to notation the rest of the code understands */
12188             sv_catpv(substitute_parse, "\\x{");
12189             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
12190             sv_catpv(substitute_parse, "}");
12191
12192             /* Point to the beginning of the next character in the sequence. */
12193             RExC_parse = endchar + 1;
12194             endchar = RExC_parse + strcspn(RExC_parse, ".}");
12195
12196         }
12197         sv_catpv(substitute_parse, ")");
12198
12199         len = SvCUR(substitute_parse);
12200
12201         /* Don't allow empty number */
12202         if (len < (STRLEN) 8) {
12203             RExC_parse = endbrace;
12204             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12205         }
12206
12207         RExC_parse = RExC_start = RExC_adjusted_start
12208                                               = SvPV_nolen(substitute_parse);
12209         RExC_end = RExC_parse + len;
12210
12211         /* The values are Unicode, and therefore not subject to recoding, but
12212          * have to be converted to native on a non-Unicode (meaning non-ASCII)
12213          * platform. */
12214 #ifdef EBCDIC
12215         RExC_recode_x_to_native = 1;
12216 #endif
12217
12218         if (node_p) {
12219             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
12220                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12221                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12222                     return FALSE;
12223                 }
12224                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#" UVxf,
12225                     (UV) flags);
12226             }
12227             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12228         }
12229
12230         /* Restore the saved values */
12231         RExC_start = RExC_adjusted_start = save_start;
12232         RExC_parse = endbrace;
12233         RExC_end = orig_end;
12234 #ifdef EBCDIC
12235         RExC_recode_x_to_native = 0;
12236 #endif
12237
12238         SvREFCNT_dec_NN(substitute_parse);
12239         nextchar(pRExC_state);
12240
12241         return TRUE;
12242     }
12243 }
12244
12245
12246 PERL_STATIC_INLINE U8
12247 S_compute_EXACTish(RExC_state_t *pRExC_state)
12248 {
12249     U8 op;
12250
12251     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12252
12253     if (! FOLD) {
12254         return (LOC)
12255                 ? EXACTL
12256                 : EXACT;
12257     }
12258
12259     op = get_regex_charset(RExC_flags);
12260     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12261         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12262                  been, so there is no hole */
12263     }
12264
12265     return op + EXACTF;
12266 }
12267
12268 PERL_STATIC_INLINE void
12269 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12270                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12271                          bool downgradable)
12272 {
12273     /* This knows the details about sizing an EXACTish node, setting flags for
12274      * it (by setting <*flagp>, and potentially populating it with a single
12275      * character.
12276      *
12277      * If <len> (the length in bytes) is non-zero, this function assumes that
12278      * the node has already been populated, and just does the sizing.  In this
12279      * case <code_point> should be the final code point that has already been
12280      * placed into the node.  This value will be ignored except that under some
12281      * circumstances <*flagp> is set based on it.
12282      *
12283      * If <len> is zero, the function assumes that the node is to contain only
12284      * the single character given by <code_point> and calculates what <len>
12285      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12286      * additionally will populate the node's STRING with <code_point> or its
12287      * fold if folding.
12288      *
12289      * In both cases <*flagp> is appropriately set
12290      *
12291      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12292      * 255, must be folded (the former only when the rules indicate it can
12293      * match 'ss')
12294      *
12295      * When it does the populating, it looks at the flag 'downgradable'.  If
12296      * true with a node that folds, it checks if the single code point
12297      * participates in a fold, and if not downgrades the node to an EXACT.
12298      * This helps the optimizer */
12299
12300     bool len_passed_in = cBOOL(len != 0);
12301     U8 character[UTF8_MAXBYTES_CASE+1];
12302
12303     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12304
12305     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12306      * sizing difference, and is extra work that is thrown away */
12307     if (downgradable && ! PASS2) {
12308         downgradable = FALSE;
12309     }
12310
12311     if (! len_passed_in) {
12312         if (UTF) {
12313             if (UVCHR_IS_INVARIANT(code_point)) {
12314                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12315                     *character = (U8) code_point;
12316                 }
12317                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12318                           ASCII, which isn't the same thing as INVARIANT on
12319                           EBCDIC, but it works there, as the extra invariants
12320                           fold to themselves) */
12321                     *character = toFOLD((U8) code_point);
12322
12323                     /* We can downgrade to an EXACT node if this character
12324                      * isn't a folding one.  Note that this assumes that
12325                      * nothing above Latin1 folds to some other invariant than
12326                      * one of these alphabetics; otherwise we would also have
12327                      * to check:
12328                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12329                      *      || ASCII_FOLD_RESTRICTED))
12330                      */
12331                     if (downgradable && PL_fold[code_point] == code_point) {
12332                         OP(node) = EXACT;
12333                     }
12334                 }
12335                 len = 1;
12336             }
12337             else if (FOLD && (! LOC
12338                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12339             {   /* Folding, and ok to do so now */
12340                 UV folded = _to_uni_fold_flags(
12341                                    code_point,
12342                                    character,
12343                                    &len,
12344                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12345                                                       ? FOLD_FLAGS_NOMIX_ASCII
12346                                                       : 0));
12347                 if (downgradable
12348                     && folded == code_point /* This quickly rules out many
12349                                                cases, avoiding the
12350                                                _invlist_contains_cp() overhead
12351                                                for those.  */
12352                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12353                 {
12354                     OP(node) = (LOC)
12355                                ? EXACTL
12356                                : EXACT;
12357                 }
12358             }
12359             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12360
12361                 /* Not folding this cp, and can output it directly */
12362                 *character = UTF8_TWO_BYTE_HI(code_point);
12363                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12364                 len = 2;
12365             }
12366             else {
12367                 uvchr_to_utf8( character, code_point);
12368                 len = UTF8SKIP(character);
12369             }
12370         } /* Else pattern isn't UTF8.  */
12371         else if (! FOLD) {
12372             *character = (U8) code_point;
12373             len = 1;
12374         } /* Else is folded non-UTF8 */
12375 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12376    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12377                                       || UNICODE_DOT_DOT_VERSION > 0)
12378         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12379 #else
12380         else if (1) {
12381 #endif
12382             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12383              * comments at join_exact()); */
12384             *character = (U8) code_point;
12385             len = 1;
12386
12387             /* Can turn into an EXACT node if we know the fold at compile time,
12388              * and it folds to itself and doesn't particpate in other folds */
12389             if (downgradable
12390                 && ! LOC
12391                 && PL_fold_latin1[code_point] == code_point
12392                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12393                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12394             {
12395                 OP(node) = EXACT;
12396             }
12397         } /* else is Sharp s.  May need to fold it */
12398         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12399             *character = 's';
12400             *(character + 1) = 's';
12401             len = 2;
12402         }
12403         else {
12404             *character = LATIN_SMALL_LETTER_SHARP_S;
12405             len = 1;
12406         }
12407     }
12408
12409     if (SIZE_ONLY) {
12410         RExC_size += STR_SZ(len);
12411     }
12412     else {
12413         RExC_emit += STR_SZ(len);
12414         STR_LEN(node) = len;
12415         if (! len_passed_in) {
12416             Copy((char *) character, STRING(node), len, char);
12417         }
12418     }
12419
12420     *flagp |= HASWIDTH;
12421
12422     /* A single character node is SIMPLE, except for the special-cased SHARP S
12423      * under /di. */
12424     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12425 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12426    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12427                                       || UNICODE_DOT_DOT_VERSION > 0)
12428         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12429             || ! FOLD || ! DEPENDS_SEMANTICS)
12430 #endif
12431     ) {
12432         *flagp |= SIMPLE;
12433     }
12434
12435     /* The OP may not be well defined in PASS1 */
12436     if (PASS2 && OP(node) == EXACTFL) {
12437         RExC_contains_locale = 1;
12438     }
12439 }
12440
12441 STATIC bool
12442 S_new_regcurly(const char *s, const char *e)
12443 {
12444     /* This is a temporary function designed to match the most lenient form of
12445      * a {m,n} quantifier we ever envision, with either number omitted, and
12446      * spaces anywhere between/before/after them.
12447      *
12448      * If this function fails, then the string it matches is very unlikely to
12449      * ever be considered a valid quantifier, so we can allow the '{' that
12450      * begins it to be considered as a literal */
12451
12452     bool has_min = FALSE;
12453     bool has_max = FALSE;
12454
12455     PERL_ARGS_ASSERT_NEW_REGCURLY;
12456
12457     if (s >= e || *s++ != '{')
12458         return FALSE;
12459
12460     while (s < e && isSPACE(*s)) {
12461         s++;
12462     }
12463     while (s < e && isDIGIT(*s)) {
12464         has_min = TRUE;
12465         s++;
12466     }
12467     while (s < e && isSPACE(*s)) {
12468         s++;
12469     }
12470
12471     if (*s == ',') {
12472         s++;
12473         while (s < e && isSPACE(*s)) {
12474             s++;
12475         }
12476         while (s < e && isDIGIT(*s)) {
12477             has_max = TRUE;
12478             s++;
12479         }
12480         while (s < e && isSPACE(*s)) {
12481             s++;
12482         }
12483     }
12484
12485     return s < e && *s == '}' && (has_min || has_max);
12486 }
12487
12488 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12489  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12490
12491 static I32
12492 S_backref_value(char *p)
12493 {
12494     const char* endptr;
12495     UV val;
12496     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12497         return (I32)val;
12498     return I32_MAX;
12499 }
12500
12501
12502 /*
12503  - regatom - the lowest level
12504
12505    Try to identify anything special at the start of the current parse position.
12506    If there is, then handle it as required. This may involve generating a
12507    single regop, such as for an assertion; or it may involve recursing, such as
12508    to handle a () structure.
12509
12510    If the string doesn't start with something special then we gobble up
12511    as much literal text as we can.  If we encounter a quantifier, we have to
12512    back off the final literal character, as that quantifier applies to just it
12513    and not to the whole string of literals.
12514
12515    Once we have been able to handle whatever type of thing started the
12516    sequence, we return.
12517
12518    Note: we have to be careful with escapes, as they can be both literal
12519    and special, and in the case of \10 and friends, context determines which.
12520
12521    A summary of the code structure is:
12522
12523    switch (first_byte) {
12524         cases for each special:
12525             handle this special;
12526             break;
12527         case '\\':
12528             switch (2nd byte) {
12529                 cases for each unambiguous special:
12530                     handle this special;
12531                     break;
12532                 cases for each ambigous special/literal:
12533                     disambiguate;
12534                     if (special)  handle here
12535                     else goto defchar;
12536                 default: // unambiguously literal:
12537                     goto defchar;
12538             }
12539         default:  // is a literal char
12540             // FALL THROUGH
12541         defchar:
12542             create EXACTish node for literal;
12543             while (more input and node isn't full) {
12544                 switch (input_byte) {
12545                    cases for each special;
12546                        make sure parse pointer is set so that the next call to
12547                            regatom will see this special first
12548                        goto loopdone; // EXACTish node terminated by prev. char
12549                    default:
12550                        append char to EXACTISH node;
12551                 }
12552                 get next input byte;
12553             }
12554         loopdone:
12555    }
12556    return the generated node;
12557
12558    Specifically there are two separate switches for handling
12559    escape sequences, with the one for handling literal escapes requiring
12560    a dummy entry for all of the special escapes that are actually handled
12561    by the other.
12562
12563    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12564    TRYAGAIN.
12565    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12566    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12567    Otherwise does not return NULL.
12568 */
12569
12570 STATIC regnode *
12571 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12572 {
12573     regnode *ret = NULL;
12574     I32 flags = 0;
12575     char *parse_start;
12576     U8 op;
12577     int invert = 0;
12578     U8 arg;
12579
12580     GET_RE_DEBUG_FLAGS_DECL;
12581
12582     *flagp = WORST;             /* Tentatively. */
12583
12584     DEBUG_PARSE("atom");
12585
12586     PERL_ARGS_ASSERT_REGATOM;
12587
12588   tryagain:
12589     parse_start = RExC_parse;
12590     assert(RExC_parse < RExC_end);
12591     switch ((U8)*RExC_parse) {
12592     case '^':
12593         RExC_seen_zerolen++;
12594         nextchar(pRExC_state);
12595         if (RExC_flags & RXf_PMf_MULTILINE)
12596             ret = reg_node(pRExC_state, MBOL);
12597         else
12598             ret = reg_node(pRExC_state, SBOL);
12599         Set_Node_Length(ret, 1); /* MJD */
12600         break;
12601     case '$':
12602         nextchar(pRExC_state);
12603         if (*RExC_parse)
12604             RExC_seen_zerolen++;
12605         if (RExC_flags & RXf_PMf_MULTILINE)
12606             ret = reg_node(pRExC_state, MEOL);
12607         else
12608             ret = reg_node(pRExC_state, SEOL);
12609         Set_Node_Length(ret, 1); /* MJD */
12610         break;
12611     case '.':
12612         nextchar(pRExC_state);
12613         if (RExC_flags & RXf_PMf_SINGLELINE)
12614             ret = reg_node(pRExC_state, SANY);
12615         else
12616             ret = reg_node(pRExC_state, REG_ANY);
12617         *flagp |= HASWIDTH|SIMPLE;
12618         MARK_NAUGHTY(1);
12619         Set_Node_Length(ret, 1); /* MJD */
12620         break;
12621     case '[':
12622     {
12623         char * const oregcomp_parse = ++RExC_parse;
12624         ret = regclass(pRExC_state, flagp,depth+1,
12625                        FALSE, /* means parse the whole char class */
12626                        TRUE, /* allow multi-char folds */
12627                        FALSE, /* don't silence non-portable warnings. */
12628                        (bool) RExC_strict,
12629                        TRUE, /* Allow an optimized regnode result */
12630                        NULL,
12631                        NULL);
12632         if (ret == NULL) {
12633             if (*flagp & (RESTART_PASS1|NEED_UTF8))
12634                 return NULL;
12635             FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12636                   (UV) *flagp);
12637         }
12638         if (*RExC_parse != ']') {
12639             RExC_parse = oregcomp_parse;
12640             vFAIL("Unmatched [");
12641         }
12642         nextchar(pRExC_state);
12643         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12644         break;
12645     }
12646     case '(':
12647         nextchar(pRExC_state);
12648         ret = reg(pRExC_state, 2, &flags,depth+1);
12649         if (ret == NULL) {
12650                 if (flags & TRYAGAIN) {
12651                     if (RExC_parse >= RExC_end) {
12652                          /* Make parent create an empty node if needed. */
12653                         *flagp |= TRYAGAIN;
12654                         return(NULL);
12655                     }
12656                     goto tryagain;
12657                 }
12658                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12659                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12660                     return NULL;
12661                 }
12662                 FAIL2("panic: reg returned NULL to regatom, flags=%#" UVxf,
12663                                                                  (UV) flags);
12664         }
12665         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12666         break;
12667     case '|':
12668     case ')':
12669         if (flags & TRYAGAIN) {
12670             *flagp |= TRYAGAIN;
12671             return NULL;
12672         }
12673         vFAIL("Internal urp");
12674                                 /* Supposed to be caught earlier. */
12675         break;
12676     case '?':
12677     case '+':
12678     case '*':
12679         RExC_parse++;
12680         vFAIL("Quantifier follows nothing");
12681         break;
12682     case '\\':
12683         /* Special Escapes
12684
12685            This switch handles escape sequences that resolve to some kind
12686            of special regop and not to literal text. Escape sequnces that
12687            resolve to literal text are handled below in the switch marked
12688            "Literal Escapes".
12689
12690            Every entry in this switch *must* have a corresponding entry
12691            in the literal escape switch. However, the opposite is not
12692            required, as the default for this switch is to jump to the
12693            literal text handling code.
12694         */
12695         RExC_parse++;
12696         switch ((U8)*RExC_parse) {
12697         /* Special Escapes */
12698         case 'A':
12699             RExC_seen_zerolen++;
12700             ret = reg_node(pRExC_state, SBOL);
12701             /* SBOL is shared with /^/ so we set the flags so we can tell
12702              * /\A/ from /^/ in split. We check ret because first pass we
12703              * have no regop struct to set the flags on. */
12704             if (PASS2)
12705                 ret->flags = 1;
12706             *flagp |= SIMPLE;
12707             goto finish_meta_pat;
12708         case 'G':
12709             ret = reg_node(pRExC_state, GPOS);
12710             RExC_seen |= REG_GPOS_SEEN;
12711             *flagp |= SIMPLE;
12712             goto finish_meta_pat;
12713         case 'K':
12714             RExC_seen_zerolen++;
12715             ret = reg_node(pRExC_state, KEEPS);
12716             *flagp |= SIMPLE;
12717             /* XXX:dmq : disabling in-place substitution seems to
12718              * be necessary here to avoid cases of memory corruption, as
12719              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
12720              */
12721             RExC_seen |= REG_LOOKBEHIND_SEEN;
12722             goto finish_meta_pat;
12723         case 'Z':
12724             ret = reg_node(pRExC_state, SEOL);
12725             *flagp |= SIMPLE;
12726             RExC_seen_zerolen++;                /* Do not optimize RE away */
12727             goto finish_meta_pat;
12728         case 'z':
12729             ret = reg_node(pRExC_state, EOS);
12730             *flagp |= SIMPLE;
12731             RExC_seen_zerolen++;                /* Do not optimize RE away */
12732             goto finish_meta_pat;
12733         case 'C':
12734             vFAIL("\\C no longer supported");
12735         case 'X':
12736             ret = reg_node(pRExC_state, CLUMP);
12737             *flagp |= HASWIDTH;
12738             goto finish_meta_pat;
12739
12740         case 'W':
12741             invert = 1;
12742             /* FALLTHROUGH */
12743         case 'w':
12744             arg = ANYOF_WORDCHAR;
12745             goto join_posix;
12746
12747         case 'B':
12748             invert = 1;
12749             /* FALLTHROUGH */
12750         case 'b':
12751           {
12752             regex_charset charset = get_regex_charset(RExC_flags);
12753
12754             RExC_seen_zerolen++;
12755             RExC_seen |= REG_LOOKBEHIND_SEEN;
12756             op = BOUND + charset;
12757
12758             if (op == BOUNDL) {
12759                 RExC_contains_locale = 1;
12760             }
12761
12762             ret = reg_node(pRExC_state, op);
12763             *flagp |= SIMPLE;
12764             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
12765                 FLAGS(ret) = TRADITIONAL_BOUND;
12766                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
12767                     OP(ret) = BOUNDA;
12768                 }
12769             }
12770             else {
12771                 STRLEN length;
12772                 char name = *RExC_parse;
12773                 char * endbrace;
12774                 RExC_parse += 2;
12775                 endbrace = strchr(RExC_parse, '}');
12776
12777                 if (! endbrace) {
12778                     vFAIL2("Missing right brace on \\%c{}", name);
12779                 }
12780                 /* XXX Need to decide whether to take spaces or not.  Should be
12781                  * consistent with \p{}, but that currently is SPACE, which
12782                  * means vertical too, which seems wrong
12783                  * while (isBLANK(*RExC_parse)) {
12784                     RExC_parse++;
12785                 }*/
12786                 if (endbrace == RExC_parse) {
12787                     RExC_parse++;  /* After the '}' */
12788                     vFAIL2("Empty \\%c{}", name);
12789                 }
12790                 length = endbrace - RExC_parse;
12791                 /*while (isBLANK(*(RExC_parse + length - 1))) {
12792                     length--;
12793                 }*/
12794                 switch (*RExC_parse) {
12795                     case 'g':
12796                         if (length != 1
12797                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
12798                         {
12799                             goto bad_bound_type;
12800                         }
12801                         FLAGS(ret) = GCB_BOUND;
12802                         break;
12803                     case 'l':
12804                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12805                             goto bad_bound_type;
12806                         }
12807                         FLAGS(ret) = LB_BOUND;
12808                         break;
12809                     case 's':
12810                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12811                             goto bad_bound_type;
12812                         }
12813                         FLAGS(ret) = SB_BOUND;
12814                         break;
12815                     case 'w':
12816                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12817                             goto bad_bound_type;
12818                         }
12819                         FLAGS(ret) = WB_BOUND;
12820                         break;
12821                     default:
12822                       bad_bound_type:
12823                         RExC_parse = endbrace;
12824                         vFAIL2utf8f(
12825                             "'%" UTF8f "' is an unknown bound type",
12826                             UTF8fARG(UTF, length, endbrace - length));
12827                         NOT_REACHED; /*NOTREACHED*/
12828                 }
12829                 RExC_parse = endbrace;
12830                 REQUIRE_UNI_RULES(flagp, NULL);
12831
12832                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
12833                     OP(ret) = BOUNDU;
12834                     length += 4;
12835
12836                     /* Don't have to worry about UTF-8, in this message because
12837                      * to get here the contents of the \b must be ASCII */
12838                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
12839                               "Using /u for '%.*s' instead of /%s",
12840                               (unsigned) length,
12841                               endbrace - length + 1,
12842                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
12843                               ? ASCII_RESTRICT_PAT_MODS
12844                               : ASCII_MORE_RESTRICT_PAT_MODS);
12845                 }
12846             }
12847
12848             if (PASS2 && invert) {
12849                 OP(ret) += NBOUND - BOUND;
12850             }
12851             goto finish_meta_pat;
12852           }
12853
12854         case 'D':
12855             invert = 1;
12856             /* FALLTHROUGH */
12857         case 'd':
12858             arg = ANYOF_DIGIT;
12859             if (! DEPENDS_SEMANTICS) {
12860                 goto join_posix;
12861             }
12862
12863             /* \d doesn't have any matches in the upper Latin1 range, hence /d
12864              * is equivalent to /u.  Changing to /u saves some branches at
12865              * runtime */
12866             op = POSIXU;
12867             goto join_posix_op_known;
12868
12869         case 'R':
12870             ret = reg_node(pRExC_state, LNBREAK);
12871             *flagp |= HASWIDTH|SIMPLE;
12872             goto finish_meta_pat;
12873
12874         case 'H':
12875             invert = 1;
12876             /* FALLTHROUGH */
12877         case 'h':
12878             arg = ANYOF_BLANK;
12879             op = POSIXU;
12880             goto join_posix_op_known;
12881
12882         case 'V':
12883             invert = 1;
12884             /* FALLTHROUGH */
12885         case 'v':
12886             arg = ANYOF_VERTWS;
12887             op = POSIXU;
12888             goto join_posix_op_known;
12889
12890         case 'S':
12891             invert = 1;
12892             /* FALLTHROUGH */
12893         case 's':
12894             arg = ANYOF_SPACE;
12895
12896           join_posix:
12897
12898             op = POSIXD + get_regex_charset(RExC_flags);
12899             if (op > POSIXA) {  /* /aa is same as /a */
12900                 op = POSIXA;
12901             }
12902             else if (op == POSIXL) {
12903                 RExC_contains_locale = 1;
12904             }
12905
12906           join_posix_op_known:
12907
12908             if (invert) {
12909                 op += NPOSIXD - POSIXD;
12910             }
12911
12912             ret = reg_node(pRExC_state, op);
12913             if (! SIZE_ONLY) {
12914                 FLAGS(ret) = namedclass_to_classnum(arg);
12915             }
12916
12917             *flagp |= HASWIDTH|SIMPLE;
12918             /* FALLTHROUGH */
12919
12920           finish_meta_pat:
12921             if (   UCHARAT(RExC_parse + 1) == '{'
12922                 && UNLIKELY(! new_regcurly(RExC_parse + 1, RExC_end)))
12923             {
12924                 RExC_parse += 2;
12925                 vFAIL("Unescaped left brace in regex is illegal here");
12926             }
12927             nextchar(pRExC_state);
12928             Set_Node_Length(ret, 2); /* MJD */
12929             break;
12930         case 'p':
12931         case 'P':
12932             RExC_parse--;
12933
12934             ret = regclass(pRExC_state, flagp,depth+1,
12935                            TRUE, /* means just parse this element */
12936                            FALSE, /* don't allow multi-char folds */
12937                            FALSE, /* don't silence non-portable warnings.  It
12938                                      would be a bug if these returned
12939                                      non-portables */
12940                            (bool) RExC_strict,
12941                            TRUE, /* Allow an optimized regnode result */
12942                            NULL,
12943                            NULL);
12944             if (*flagp & RESTART_PASS1)
12945                 return NULL;
12946             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
12947              * multi-char folds are allowed.  */
12948             if (!ret)
12949                 FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12950                       (UV) *flagp);
12951
12952             RExC_parse--;
12953
12954             Set_Node_Offset(ret, parse_start);
12955             Set_Node_Cur_Length(ret, parse_start - 2);
12956             nextchar(pRExC_state);
12957             break;
12958         case 'N':
12959             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12960              * \N{...} evaluates to a sequence of more than one code points).
12961              * The function call below returns a regnode, which is our result.
12962              * The parameters cause it to fail if the \N{} evaluates to a
12963              * single code point; we handle those like any other literal.  The
12964              * reason that the multicharacter case is handled here and not as
12965              * part of the EXACtish code is because of quantifiers.  In
12966              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12967              * this way makes that Just Happen. dmq.
12968              * join_exact() will join this up with adjacent EXACTish nodes
12969              * later on, if appropriate. */
12970             ++RExC_parse;
12971             if (grok_bslash_N(pRExC_state,
12972                               &ret,     /* Want a regnode returned */
12973                               NULL,     /* Fail if evaluates to a single code
12974                                            point */
12975                               NULL,     /* Don't need a count of how many code
12976                                            points */
12977                               flagp,
12978                               RExC_strict,
12979                               depth)
12980             ) {
12981                 break;
12982             }
12983
12984             if (*flagp & RESTART_PASS1)
12985                 return NULL;
12986
12987             /* Here, evaluates to a single code point.  Go get that */
12988             RExC_parse = parse_start;
12989             goto defchar;
12990
12991         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12992       parse_named_seq:
12993         {
12994             char ch;
12995             if (   RExC_parse >= RExC_end - 1
12996                 || ((   ch = RExC_parse[1]) != '<'
12997                                       && ch != '\''
12998                                       && ch != '{'))
12999             {
13000                 RExC_parse++;
13001                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
13002                 vFAIL2("Sequence %.2s... not terminated",parse_start);
13003             } else {
13004                 RExC_parse += 2;
13005                 ret = handle_named_backref(pRExC_state,
13006                                            flagp,
13007                                            parse_start,
13008                                            (ch == '<')
13009                                            ? '>'
13010                                            : (ch == '{')
13011                                              ? '}'
13012                                              : '\'');
13013             }
13014             break;
13015         }
13016         case 'g':
13017         case '1': case '2': case '3': case '4':
13018         case '5': case '6': case '7': case '8': case '9':
13019             {
13020                 I32 num;
13021                 bool hasbrace = 0;
13022
13023                 if (*RExC_parse == 'g') {
13024                     bool isrel = 0;
13025
13026                     RExC_parse++;
13027                     if (*RExC_parse == '{') {
13028                         RExC_parse++;
13029                         hasbrace = 1;
13030                     }
13031                     if (*RExC_parse == '-') {
13032                         RExC_parse++;
13033                         isrel = 1;
13034                     }
13035                     if (hasbrace && !isDIGIT(*RExC_parse)) {
13036                         if (isrel) RExC_parse--;
13037                         RExC_parse -= 2;
13038                         goto parse_named_seq;
13039                     }
13040
13041                     if (RExC_parse >= RExC_end) {
13042                         goto unterminated_g;
13043                     }
13044                     num = S_backref_value(RExC_parse);
13045                     if (num == 0)
13046                         vFAIL("Reference to invalid group 0");
13047                     else if (num == I32_MAX) {
13048                          if (isDIGIT(*RExC_parse))
13049                             vFAIL("Reference to nonexistent group");
13050                         else
13051                           unterminated_g:
13052                             vFAIL("Unterminated \\g... pattern");
13053                     }
13054
13055                     if (isrel) {
13056                         num = RExC_npar - num;
13057                         if (num < 1)
13058                             vFAIL("Reference to nonexistent or unclosed group");
13059                     }
13060                 }
13061                 else {
13062                     num = S_backref_value(RExC_parse);
13063                     /* bare \NNN might be backref or octal - if it is larger
13064                      * than or equal RExC_npar then it is assumed to be an
13065                      * octal escape. Note RExC_npar is +1 from the actual
13066                      * number of parens. */
13067                     /* Note we do NOT check if num == I32_MAX here, as that is
13068                      * handled by the RExC_npar check */
13069
13070                     if (
13071                         /* any numeric escape < 10 is always a backref */
13072                         num > 9
13073                         /* any numeric escape < RExC_npar is a backref */
13074                         && num >= RExC_npar
13075                         /* cannot be an octal escape if it starts with 8 */
13076                         && *RExC_parse != '8'
13077                         /* cannot be an octal escape it it starts with 9 */
13078                         && *RExC_parse != '9'
13079                     )
13080                     {
13081                         /* Probably not a backref, instead likely to be an
13082                          * octal character escape, e.g. \35 or \777.
13083                          * The above logic should make it obvious why using
13084                          * octal escapes in patterns is problematic. - Yves */
13085                         RExC_parse = parse_start;
13086                         goto defchar;
13087                     }
13088                 }
13089
13090                 /* At this point RExC_parse points at a numeric escape like
13091                  * \12 or \88 or something similar, which we should NOT treat
13092                  * as an octal escape. It may or may not be a valid backref
13093                  * escape. For instance \88888888 is unlikely to be a valid
13094                  * backref. */
13095                 while (isDIGIT(*RExC_parse))
13096                     RExC_parse++;
13097                 if (hasbrace) {
13098                     if (*RExC_parse != '}')
13099                         vFAIL("Unterminated \\g{...} pattern");
13100                     RExC_parse++;
13101                 }
13102                 if (!SIZE_ONLY) {
13103                     if (num > (I32)RExC_rx->nparens)
13104                         vFAIL("Reference to nonexistent group");
13105                 }
13106                 RExC_sawback = 1;
13107                 ret = reganode(pRExC_state,
13108                                ((! FOLD)
13109                                  ? REF
13110                                  : (ASCII_FOLD_RESTRICTED)
13111                                    ? REFFA
13112                                    : (AT_LEAST_UNI_SEMANTICS)
13113                                      ? REFFU
13114                                      : (LOC)
13115                                        ? REFFL
13116                                        : REFF),
13117                                 num);
13118                 *flagp |= HASWIDTH;
13119
13120                 /* override incorrect value set in reganode MJD */
13121                 Set_Node_Offset(ret, parse_start);
13122                 Set_Node_Cur_Length(ret, parse_start-1);
13123                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13124                                         FALSE /* Don't force to /x */ );
13125             }
13126             break;
13127         case '\0':
13128             if (RExC_parse >= RExC_end)
13129                 FAIL("Trailing \\");
13130             /* FALLTHROUGH */
13131         default:
13132             /* Do not generate "unrecognized" warnings here, we fall
13133                back into the quick-grab loop below */
13134             RExC_parse = parse_start;
13135             goto defchar;
13136         } /* end of switch on a \foo sequence */
13137         break;
13138
13139     case '#':
13140
13141         /* '#' comments should have been spaced over before this function was
13142          * called */
13143         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13144         /*
13145         if (RExC_flags & RXf_PMf_EXTENDED) {
13146             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13147             if (RExC_parse < RExC_end)
13148                 goto tryagain;
13149         }
13150         */
13151
13152         /* FALLTHROUGH */
13153
13154     default:
13155           defchar: {
13156
13157             /* Here, we have determined that the next thing is probably a
13158              * literal character.  RExC_parse points to the first byte of its
13159              * definition.  (It still may be an escape sequence that evaluates
13160              * to a single character) */
13161
13162             STRLEN len = 0;
13163             UV ender = 0;
13164             char *p;
13165             char *s;
13166 #define MAX_NODE_STRING_SIZE 127
13167             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
13168             char *s0;
13169             U8 upper_parse = MAX_NODE_STRING_SIZE;
13170             U8 node_type = compute_EXACTish(pRExC_state);
13171             bool next_is_quantifier;
13172             char * oldp = NULL;
13173
13174             /* We can convert EXACTF nodes to EXACTFU if they contain only
13175              * characters that match identically regardless of the target
13176              * string's UTF8ness.  The reason to do this is that EXACTF is not
13177              * trie-able, EXACTFU is.
13178              *
13179              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13180              * contain only above-Latin1 characters (hence must be in UTF8),
13181              * which don't participate in folds with Latin1-range characters,
13182              * as the latter's folds aren't known until runtime.  (We don't
13183              * need to figure this out until pass 2) */
13184             bool maybe_exactfu = PASS2
13185                                && (node_type == EXACTF || node_type == EXACTFL);
13186
13187             /* If a folding node contains only code points that don't
13188              * participate in folds, it can be changed into an EXACT node,
13189              * which allows the optimizer more things to look for */
13190             bool maybe_exact;
13191
13192             ret = reg_node(pRExC_state, node_type);
13193
13194             /* In pass1, folded, we use a temporary buffer instead of the
13195              * actual node, as the node doesn't exist yet */
13196             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
13197
13198             s0 = s;
13199
13200           reparse:
13201
13202             /* We look for the EXACTFish to EXACT node optimizaton only if
13203              * folding.  (And we don't need to figure this out until pass 2).
13204              * XXX It might actually make sense to split the node into portions
13205              * that are exact and ones that aren't, so that we could later use
13206              * the exact ones to find the longest fixed and floating strings.
13207              * One would want to join them back into a larger node.  One could
13208              * use a pseudo regnode like 'EXACT_ORIG_FOLD' */
13209             maybe_exact = FOLD && PASS2;
13210
13211             /* XXX The node can hold up to 255 bytes, yet this only goes to
13212              * 127.  I (khw) do not know why.  Keeping it somewhat less than
13213              * 255 allows us to not have to worry about overflow due to
13214              * converting to utf8 and fold expansion, but that value is
13215              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
13216              * split up by this limit into a single one using the real max of
13217              * 255.  Even at 127, this breaks under rare circumstances.  If
13218              * folding, we do not want to split a node at a character that is a
13219              * non-final in a multi-char fold, as an input string could just
13220              * happen to want to match across the node boundary.  The join
13221              * would solve that problem if the join actually happens.  But a
13222              * series of more than two nodes in a row each of 127 would cause
13223              * the first join to succeed to get to 254, but then there wouldn't
13224              * be room for the next one, which could at be one of those split
13225              * multi-char folds.  I don't know of any fool-proof solution.  One
13226              * could back off to end with only a code point that isn't such a
13227              * non-final, but it is possible for there not to be any in the
13228              * entire node. */
13229
13230             assert(   ! UTF     /* Is at the beginning of a character */
13231                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13232                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13233
13234             /* Here, we have a literal character.  Find the maximal string of
13235              * them in the input that we can fit into a single EXACTish node.
13236              * We quit at the first non-literal or when the node gets full */
13237             for (p = RExC_parse;
13238                  len < upper_parse && p < RExC_end;
13239                  len++)
13240             {
13241                 oldp = p;
13242
13243                 /* White space has already been ignored */
13244                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13245                        || ! is_PATWS_safe((p), RExC_end, UTF));
13246
13247                 switch ((U8)*p) {
13248                 case '^':
13249                 case '$':
13250                 case '.':
13251                 case '[':
13252                 case '(':
13253                 case ')':
13254                 case '|':
13255                     goto loopdone;
13256                 case '\\':
13257                     /* Literal Escapes Switch
13258
13259                        This switch is meant to handle escape sequences that
13260                        resolve to a literal character.
13261
13262                        Every escape sequence that represents something
13263                        else, like an assertion or a char class, is handled
13264                        in the switch marked 'Special Escapes' above in this
13265                        routine, but also has an entry here as anything that
13266                        isn't explicitly mentioned here will be treated as
13267                        an unescaped equivalent literal.
13268                     */
13269
13270                     switch ((U8)*++p) {
13271                     /* These are all the special escapes. */
13272                     case 'A':             /* Start assertion */
13273                     case 'b': case 'B':   /* Word-boundary assertion*/
13274                     case 'C':             /* Single char !DANGEROUS! */
13275                     case 'd': case 'D':   /* digit class */
13276                     case 'g': case 'G':   /* generic-backref, pos assertion */
13277                     case 'h': case 'H':   /* HORIZWS */
13278                     case 'k': case 'K':   /* named backref, keep marker */
13279                     case 'p': case 'P':   /* Unicode property */
13280                               case 'R':   /* LNBREAK */
13281                     case 's': case 'S':   /* space class */
13282                     case 'v': case 'V':   /* VERTWS */
13283                     case 'w': case 'W':   /* word class */
13284                     case 'X':             /* eXtended Unicode "combining
13285                                              character sequence" */
13286                     case 'z': case 'Z':   /* End of line/string assertion */
13287                         --p;
13288                         goto loopdone;
13289
13290                     /* Anything after here is an escape that resolves to a
13291                        literal. (Except digits, which may or may not)
13292                      */
13293                     case 'n':
13294                         ender = '\n';
13295                         p++;
13296                         break;
13297                     case 'N': /* Handle a single-code point named character. */
13298                         RExC_parse = p + 1;
13299                         if (! grok_bslash_N(pRExC_state,
13300                                             NULL,   /* Fail if evaluates to
13301                                                        anything other than a
13302                                                        single code point */
13303                                             &ender, /* The returned single code
13304                                                        point */
13305                                             NULL,   /* Don't need a count of
13306                                                        how many code points */
13307                                             flagp,
13308                                             RExC_strict,
13309                                             depth)
13310                         ) {
13311                             if (*flagp & NEED_UTF8)
13312                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13313                             if (*flagp & RESTART_PASS1)
13314                                 return NULL;
13315
13316                             /* Here, it wasn't a single code point.  Go close
13317                              * up this EXACTish node.  The switch() prior to
13318                              * this switch handles the other cases */
13319                             RExC_parse = p = oldp;
13320                             goto loopdone;
13321                         }
13322                         p = RExC_parse;
13323                         RExC_parse = parse_start;
13324                         if (ender > 0xff) {
13325                             REQUIRE_UTF8(flagp);
13326                         }
13327                         break;
13328                     case 'r':
13329                         ender = '\r';
13330                         p++;
13331                         break;
13332                     case 't':
13333                         ender = '\t';
13334                         p++;
13335                         break;
13336                     case 'f':
13337                         ender = '\f';
13338                         p++;
13339                         break;
13340                     case 'e':
13341                         ender = ESC_NATIVE;
13342                         p++;
13343                         break;
13344                     case 'a':
13345                         ender = '\a';
13346                         p++;
13347                         break;
13348                     case 'o':
13349                         {
13350                             UV result;
13351                             const char* error_msg;
13352
13353                             bool valid = grok_bslash_o(&p,
13354                                                        &result,
13355                                                        &error_msg,
13356                                                        PASS2, /* out warnings */
13357                                                        (bool) RExC_strict,
13358                                                        TRUE, /* Output warnings
13359                                                                 for non-
13360                                                                 portables */
13361                                                        UTF);
13362                             if (! valid) {
13363                                 RExC_parse = p; /* going to die anyway; point
13364                                                    to exact spot of failure */
13365                                 vFAIL(error_msg);
13366                             }
13367                             ender = result;
13368                             if (ender > 0xff) {
13369                                 REQUIRE_UTF8(flagp);
13370                             }
13371                             break;
13372                         }
13373                     case 'x':
13374                         {
13375                             UV result = UV_MAX; /* initialize to erroneous
13376                                                    value */
13377                             const char* error_msg;
13378
13379                             bool valid = grok_bslash_x(&p,
13380                                                        &result,
13381                                                        &error_msg,
13382                                                        PASS2, /* out warnings */
13383                                                        (bool) RExC_strict,
13384                                                        TRUE, /* Silence warnings
13385                                                                 for non-
13386                                                                 portables */
13387                                                        UTF);
13388                             if (! valid) {
13389                                 RExC_parse = p; /* going to die anyway; point
13390                                                    to exact spot of failure */
13391                                 vFAIL(error_msg);
13392                             }
13393                             ender = result;
13394
13395                             if (ender < 0x100) {
13396 #ifdef EBCDIC
13397                                 if (RExC_recode_x_to_native) {
13398                                     ender = LATIN1_TO_NATIVE(ender);
13399                                 }
13400 #endif
13401                             }
13402                             else {
13403                                 REQUIRE_UTF8(flagp);
13404                             }
13405                             break;
13406                         }
13407                     case 'c':
13408                         p++;
13409                         ender = grok_bslash_c(*p++, PASS2);
13410                         break;
13411                     case '8': case '9': /* must be a backreference */
13412                         --p;
13413                         /* we have an escape like \8 which cannot be an octal escape
13414                          * so we exit the loop, and let the outer loop handle this
13415                          * escape which may or may not be a legitimate backref. */
13416                         goto loopdone;
13417                     case '1': case '2': case '3':case '4':
13418                     case '5': case '6': case '7':
13419                         /* When we parse backslash escapes there is ambiguity
13420                          * between backreferences and octal escapes. Any escape
13421                          * from \1 - \9 is a backreference, any multi-digit
13422                          * escape which does not start with 0 and which when
13423                          * evaluated as decimal could refer to an already
13424                          * parsed capture buffer is a back reference. Anything
13425                          * else is octal.
13426                          *
13427                          * Note this implies that \118 could be interpreted as
13428                          * 118 OR as "\11" . "8" depending on whether there
13429                          * were 118 capture buffers defined already in the
13430                          * pattern.  */
13431
13432                         /* NOTE, RExC_npar is 1 more than the actual number of
13433                          * parens we have seen so far, hence the < RExC_npar below. */
13434
13435                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13436                         {  /* Not to be treated as an octal constant, go
13437                                    find backref */
13438                             --p;
13439                             goto loopdone;
13440                         }
13441                         /* FALLTHROUGH */
13442                     case '0':
13443                         {
13444                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13445                             STRLEN numlen = 3;
13446                             ender = grok_oct(p, &numlen, &flags, NULL);
13447                             if (ender > 0xff) {
13448                                 REQUIRE_UTF8(flagp);
13449                             }
13450                             p += numlen;
13451                             if (PASS2   /* like \08, \178 */
13452                                 && numlen < 3
13453                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13454                             {
13455                                 reg_warn_non_literal_string(
13456                                          p + 1,
13457                                          form_short_octal_warning(p, numlen));
13458                             }
13459                         }
13460                         break;
13461                     case '\0':
13462                         if (p >= RExC_end)
13463                             FAIL("Trailing \\");
13464                         /* FALLTHROUGH */
13465                     default:
13466                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13467                             /* Include any left brace following the alpha to emphasize
13468                              * that it could be part of an escape at some point
13469                              * in the future */
13470                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13471                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13472                         }
13473                         goto normal_default;
13474                     } /* End of switch on '\' */
13475                     break;
13476                 case '{':
13477                     /* Currently we allow an lbrace at the start of a construct
13478                      * without raising a warning.  This is because we think we
13479                      * will never want such a brace to be meant to be other
13480                      * than taken literally. */
13481                     if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
13482
13483                         /* But, we raise a fatal warning otherwise, as the
13484                          * deprecation cycle has come and gone.  Except that it
13485                          * turns out that some heavily-relied on upstream
13486                          * software, notably GNU Autoconf, have failed to fix
13487                          * their uses.  For these, don't make it fatal unless
13488                          * we anticipate using the '{' for something else.
13489                          * This happens after any alpha, and for a looser {m,n}
13490                          * quantifier specification */
13491                         if (      RExC_strict
13492                             || (  p > parse_start + 1
13493                                 && isALPHA_A(*(p - 1))
13494                                 && *(p - 2) == '\\')
13495                             || new_regcurly(p, RExC_end))
13496                         {
13497                             RExC_parse = p + 1;
13498                             vFAIL("Unescaped left brace in regex is "
13499                                   "illegal here");
13500                         }
13501                         if (PASS2) {
13502                             ckWARNregdep(p + 1,
13503                                         "Unescaped left brace in regex is "
13504                                         "deprecated here (and will be fatal "
13505                                         "in Perl 5.30), passed through");
13506                         }
13507                     }
13508                     goto normal_default;
13509                 case '}':
13510                 case ']':
13511                     if (PASS2 && p > RExC_parse && RExC_strict) {
13512                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
13513                     }
13514                     /*FALLTHROUGH*/
13515                 default:    /* A literal character */
13516                   normal_default:
13517                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13518                         STRLEN numlen;
13519                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13520                                                &numlen, UTF8_ALLOW_DEFAULT);
13521                         p += numlen;
13522                     }
13523                     else
13524                         ender = (U8) *p++;
13525                     break;
13526                 } /* End of switch on the literal */
13527
13528                 /* Here, have looked at the literal character and <ender>
13529                  * contains its ordinal, <p> points to the character after it.
13530                  * We need to check if the next non-ignored thing is a
13531                  * quantifier.  Move <p> to after anything that should be
13532                  * ignored, which, as a side effect, positions <p> for the next
13533                  * loop iteration */
13534                 skip_to_be_ignored_text(pRExC_state, &p,
13535                                         FALSE /* Don't force to /x */ );
13536
13537                 /* If the next thing is a quantifier, it applies to this
13538                  * character only, which means that this character has to be in
13539                  * its own node and can't just be appended to the string in an
13540                  * existing node, so if there are already other characters in
13541                  * the node, close the node with just them, and set up to do
13542                  * this character again next time through, when it will be the
13543                  * only thing in its new node */
13544
13545                 next_is_quantifier =    LIKELY(p < RExC_end)
13546                                      && UNLIKELY(ISMULT2(p));
13547
13548                 if (next_is_quantifier && LIKELY(len)) {
13549                     p = oldp;
13550                     goto loopdone;
13551                 }
13552
13553                 /* Ready to add 'ender' to the node */
13554
13555                 if (! FOLD) {  /* The simple case, just append the literal */
13556
13557                     /* In the sizing pass, we need only the size of the
13558                      * character we are appending, hence we can delay getting
13559                      * its representation until PASS2. */
13560                     if (SIZE_ONLY) {
13561                         if (UTF) {
13562                             const STRLEN unilen = UVCHR_SKIP(ender);
13563                             s += unilen;
13564
13565                             /* We have to subtract 1 just below (and again in
13566                              * the corresponding PASS2 code) because the loop
13567                              * increments <len> each time, as all but this path
13568                              * (and one other) through it add a single byte to
13569                              * the EXACTish node.  But these paths would change
13570                              * len to be the correct final value, so cancel out
13571                              * the increment that follows */
13572                             len += unilen - 1;
13573                         }
13574                         else {
13575                             s++;
13576                         }
13577                     } else { /* PASS2 */
13578                       not_fold_common:
13579                         if (UTF) {
13580                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13581                             len += (char *) new_s - s - 1;
13582                             s = (char *) new_s;
13583                         }
13584                         else {
13585                             *(s++) = (char) ender;
13586                         }
13587                     }
13588                 }
13589                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13590
13591                     /* Here are folding under /l, and the code point is
13592                      * problematic.  First, we know we can't simplify things */
13593                     maybe_exact = FALSE;
13594                     maybe_exactfu = FALSE;
13595
13596                     /* A problematic code point in this context means that its
13597                      * fold isn't known until runtime, so we can't fold it now.
13598                      * (The non-problematic code points are the above-Latin1
13599                      * ones that fold to also all above-Latin1.  Their folds
13600                      * don't vary no matter what the locale is.) But here we
13601                      * have characters whose fold depends on the locale.
13602                      * Unlike the non-folding case above, we have to keep track
13603                      * of these in the sizing pass, so that we can make sure we
13604                      * don't split too-long nodes in the middle of a potential
13605                      * multi-char fold.  And unlike the regular fold case
13606                      * handled in the else clauses below, we don't actually
13607                      * fold and don't have special cases to consider.  What we
13608                      * do for both passes is the PASS2 code for non-folding */
13609                     goto not_fold_common;
13610                 }
13611                 else /* A regular FOLD code point */
13612                     if (! (   UTF
13613 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13614    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13615                                       || UNICODE_DOT_DOT_VERSION > 0)
13616                             /* See comments for join_exact() as to why we fold
13617                              * this non-UTF at compile time */
13618                             || (   node_type == EXACTFU
13619                                 && ender == LATIN_SMALL_LETTER_SHARP_S)
13620 #endif
13621                 )) {
13622                     /* Here, are folding and are not UTF-8 encoded; therefore
13623                      * the character must be in the range 0-255, and is not /l
13624                      * (Not /l because we already handled these under /l in
13625                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13626                     if (IS_IN_SOME_FOLD_L1(ender)) {
13627                         maybe_exact = FALSE;
13628
13629                         /* See if the character's fold differs between /d and
13630                          * /u.  This includes the multi-char fold SHARP S to
13631                          * 'ss' */
13632                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13633                             RExC_seen_unfolded_sharp_s = 1;
13634                             maybe_exactfu = FALSE;
13635                         }
13636                         else if (maybe_exactfu
13637                             && (PL_fold[ender] != PL_fold_latin1[ender]
13638 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13639    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13640                                       || UNICODE_DOT_DOT_VERSION > 0)
13641                                 || (   len > 0
13642                                     && isALPHA_FOLD_EQ(ender, 's')
13643                                     && isALPHA_FOLD_EQ(*(s-1), 's'))
13644 #endif
13645                         )) {
13646                             maybe_exactfu = FALSE;
13647                         }
13648                     }
13649
13650                     /* Even when folding, we store just the input character, as
13651                      * we have an array that finds its fold quickly */
13652                     *(s++) = (char) ender;
13653                 }
13654                 else {  /* FOLD, and UTF (or sharp s) */
13655                     /* Unlike the non-fold case, we do actually have to
13656                      * calculate the results here in pass 1.  This is for two
13657                      * reasons, the folded length may be longer than the
13658                      * unfolded, and we have to calculate how many EXACTish
13659                      * nodes it will take; and we may run out of room in a node
13660                      * in the middle of a potential multi-char fold, and have
13661                      * to back off accordingly.  */
13662
13663                     UV folded;
13664                     if (isASCII_uni(ender)) {
13665                         folded = toFOLD(ender);
13666                         *(s)++ = (U8) folded;
13667                     }
13668                     else {
13669                         STRLEN foldlen;
13670
13671                         folded = _to_uni_fold_flags(
13672                                      ender,
13673                                      (U8 *) s,
13674                                      &foldlen,
13675                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
13676                                                         ? FOLD_FLAGS_NOMIX_ASCII
13677                                                         : 0));
13678                         s += foldlen;
13679
13680                         /* The loop increments <len> each time, as all but this
13681                          * path (and one other) through it add a single byte to
13682                          * the EXACTish node.  But this one has changed len to
13683                          * be the correct final value, so subtract one to
13684                          * cancel out the increment that follows */
13685                         len += foldlen - 1;
13686                     }
13687                     /* If this node only contains non-folding code points so
13688                      * far, see if this new one is also non-folding */
13689                     if (maybe_exact) {
13690                         if (folded != ender) {
13691                             maybe_exact = FALSE;
13692                         }
13693                         else {
13694                             /* Here the fold is the original; we have to check
13695                              * further to see if anything folds to it */
13696                             if (_invlist_contains_cp(PL_utf8_foldable,
13697                                                         ender))
13698                             {
13699                                 maybe_exact = FALSE;
13700                             }
13701                         }
13702                     }
13703                     ender = folded;
13704                 }
13705
13706                 if (next_is_quantifier) {
13707
13708                     /* Here, the next input is a quantifier, and to get here,
13709                      * the current character is the only one in the node.
13710                      * Also, here <len> doesn't include the final byte for this
13711                      * character */
13712                     len++;
13713                     goto loopdone;
13714                 }
13715
13716             } /* End of loop through literal characters */
13717
13718             /* Here we have either exhausted the input or ran out of room in
13719              * the node.  (If we encountered a character that can't be in the
13720              * node, transfer is made directly to <loopdone>, and so we
13721              * wouldn't have fallen off the end of the loop.)  In the latter
13722              * case, we artificially have to split the node into two, because
13723              * we just don't have enough space to hold everything.  This
13724              * creates a problem if the final character participates in a
13725              * multi-character fold in the non-final position, as a match that
13726              * should have occurred won't, due to the way nodes are matched,
13727              * and our artificial boundary.  So back off until we find a non-
13728              * problematic character -- one that isn't at the beginning or
13729              * middle of such a fold.  (Either it doesn't participate in any
13730              * folds, or appears only in the final position of all the folds it
13731              * does participate in.)  A better solution with far fewer false
13732              * positives, and that would fill the nodes more completely, would
13733              * be to actually have available all the multi-character folds to
13734              * test against, and to back-off only far enough to be sure that
13735              * this node isn't ending with a partial one.  <upper_parse> is set
13736              * further below (if we need to reparse the node) to include just
13737              * up through that final non-problematic character that this code
13738              * identifies, so when it is set to less than the full node, we can
13739              * skip the rest of this */
13740             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
13741
13742                 const STRLEN full_len = len;
13743
13744                 assert(len >= MAX_NODE_STRING_SIZE);
13745
13746                 /* Here, <s> points to the final byte of the final character.
13747                  * Look backwards through the string until find a non-
13748                  * problematic character */
13749
13750                 if (! UTF) {
13751
13752                     /* This has no multi-char folds to non-UTF characters */
13753                     if (ASCII_FOLD_RESTRICTED) {
13754                         goto loopdone;
13755                     }
13756
13757                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
13758                     len = s - s0 + 1;
13759                 }
13760                 else {
13761                     if (!  PL_NonL1NonFinalFold) {
13762                         PL_NonL1NonFinalFold = _new_invlist_C_array(
13763                                         NonL1_Perl_Non_Final_Folds_invlist);
13764                     }
13765
13766                     /* Point to the first byte of the final character */
13767                     s = (char *) utf8_hop((U8 *) s, -1);
13768
13769                     while (s >= s0) {   /* Search backwards until find
13770                                            non-problematic char */
13771                         if (UTF8_IS_INVARIANT(*s)) {
13772
13773                             /* There are no ascii characters that participate
13774                              * in multi-char folds under /aa.  In EBCDIC, the
13775                              * non-ascii invariants are all control characters,
13776                              * so don't ever participate in any folds. */
13777                             if (ASCII_FOLD_RESTRICTED
13778                                 || ! IS_NON_FINAL_FOLD(*s))
13779                             {
13780                                 break;
13781                             }
13782                         }
13783                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
13784                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
13785                                                                   *s, *(s+1))))
13786                             {
13787                                 break;
13788                             }
13789                         }
13790                         else if (! _invlist_contains_cp(
13791                                         PL_NonL1NonFinalFold,
13792                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
13793                         {
13794                             break;
13795                         }
13796
13797                         /* Here, the current character is problematic in that
13798                          * it does occur in the non-final position of some
13799                          * fold, so try the character before it, but have to
13800                          * special case the very first byte in the string, so
13801                          * we don't read outside the string */
13802                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
13803                     } /* End of loop backwards through the string */
13804
13805                     /* If there were only problematic characters in the string,
13806                      * <s> will point to before s0, in which case the length
13807                      * should be 0, otherwise include the length of the
13808                      * non-problematic character just found */
13809                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
13810                 }
13811
13812                 /* Here, have found the final character, if any, that is
13813                  * non-problematic as far as ending the node without splitting
13814                  * it across a potential multi-char fold.  <len> contains the
13815                  * number of bytes in the node up-to and including that
13816                  * character, or is 0 if there is no such character, meaning
13817                  * the whole node contains only problematic characters.  In
13818                  * this case, give up and just take the node as-is.  We can't
13819                  * do any better */
13820                 if (len == 0) {
13821                     len = full_len;
13822
13823                     /* If the node ends in an 's' we make sure it stays EXACTF,
13824                      * as if it turns into an EXACTFU, it could later get
13825                      * joined with another 's' that would then wrongly match
13826                      * the sharp s */
13827                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
13828                     {
13829                         maybe_exactfu = FALSE;
13830                     }
13831                 } else {
13832
13833                     /* Here, the node does contain some characters that aren't
13834                      * problematic.  If one such is the final character in the
13835                      * node, we are done */
13836                     if (len == full_len) {
13837                         goto loopdone;
13838                     }
13839                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
13840
13841                         /* If the final character is problematic, but the
13842                          * penultimate is not, back-off that last character to
13843                          * later start a new node with it */
13844                         p = oldp;
13845                         goto loopdone;
13846                     }
13847
13848                     /* Here, the final non-problematic character is earlier
13849                      * in the input than the penultimate character.  What we do
13850                      * is reparse from the beginning, going up only as far as
13851                      * this final ok one, thus guaranteeing that the node ends
13852                      * in an acceptable character.  The reason we reparse is
13853                      * that we know how far in the character is, but we don't
13854                      * know how to correlate its position with the input parse.
13855                      * An alternate implementation would be to build that
13856                      * correlation as we go along during the original parse,
13857                      * but that would entail extra work for every node, whereas
13858                      * this code gets executed only when the string is too
13859                      * large for the node, and the final two characters are
13860                      * problematic, an infrequent occurrence.  Yet another
13861                      * possible strategy would be to save the tail of the
13862                      * string, and the next time regatom is called, initialize
13863                      * with that.  The problem with this is that unless you
13864                      * back off one more character, you won't be guaranteed
13865                      * regatom will get called again, unless regbranch,
13866                      * regpiece ... are also changed.  If you do back off that
13867                      * extra character, so that there is input guaranteed to
13868                      * force calling regatom, you can't handle the case where
13869                      * just the first character in the node is acceptable.  I
13870                      * (khw) decided to try this method which doesn't have that
13871                      * pitfall; if performance issues are found, we can do a
13872                      * combination of the current approach plus that one */
13873                     upper_parse = len;
13874                     len = 0;
13875                     s = s0;
13876                     goto reparse;
13877                 }
13878             }   /* End of verifying node ends with an appropriate char */
13879
13880           loopdone:   /* Jumped to when encounters something that shouldn't be
13881                          in the node */
13882
13883             /* I (khw) don't know if you can get here with zero length, but the
13884              * old code handled this situation by creating a zero-length EXACT
13885              * node.  Might as well be NOTHING instead */
13886             if (len == 0) {
13887                 OP(ret) = NOTHING;
13888             }
13889             else {
13890                 if (FOLD) {
13891                     /* If 'maybe_exact' is still set here, means there are no
13892                      * code points in the node that participate in folds;
13893                      * similarly for 'maybe_exactfu' and code points that match
13894                      * differently depending on UTF8ness of the target string
13895                      * (for /u), or depending on locale for /l */
13896                     if (maybe_exact) {
13897                         OP(ret) = (LOC)
13898                                   ? EXACTL
13899                                   : EXACT;
13900                     }
13901                     else if (maybe_exactfu) {
13902                         OP(ret) = (LOC)
13903                                   ? EXACTFLU8
13904                                   : EXACTFU;
13905                     }
13906                 }
13907                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
13908                                            FALSE /* Don't look to see if could
13909                                                     be turned into an EXACT
13910                                                     node, as we have already
13911                                                     computed that */
13912                                           );
13913             }
13914
13915             RExC_parse = p - 1;
13916             Set_Node_Cur_Length(ret, parse_start);
13917             RExC_parse = p;
13918             {
13919                 /* len is STRLEN which is unsigned, need to copy to signed */
13920                 IV iv = len;
13921                 if (iv < 0)
13922                     vFAIL("Internal disaster");
13923             }
13924
13925         } /* End of label 'defchar:' */
13926         break;
13927     } /* End of giant switch on input character */
13928
13929     /* Position parse to next real character */
13930     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13931                                             FALSE /* Don't force to /x */ );
13932     if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
13933         ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here (and will be fatal in Perl 5.30), passed through");
13934     }
13935
13936     return(ret);
13937 }
13938
13939
13940 STATIC void
13941 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
13942 {
13943     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13944      * sets up the bitmap and any flags, removing those code points from the
13945      * inversion list, setting it to NULL should it become completely empty */
13946
13947     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13948     assert(PL_regkind[OP(node)] == ANYOF);
13949
13950     ANYOF_BITMAP_ZERO(node);
13951     if (*invlist_ptr) {
13952
13953         /* This gets set if we actually need to modify things */
13954         bool change_invlist = FALSE;
13955
13956         UV start, end;
13957
13958         /* Start looking through *invlist_ptr */
13959         invlist_iterinit(*invlist_ptr);
13960         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13961             UV high;
13962             int i;
13963
13964             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13965                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13966             }
13967
13968             /* Quit if are above what we should change */
13969             if (start >= NUM_ANYOF_CODE_POINTS) {
13970                 break;
13971             }
13972
13973             change_invlist = TRUE;
13974
13975             /* Set all the bits in the range, up to the max that we are doing */
13976             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13977                    ? end
13978                    : NUM_ANYOF_CODE_POINTS - 1;
13979             for (i = start; i <= (int) high; i++) {
13980                 if (! ANYOF_BITMAP_TEST(node, i)) {
13981                     ANYOF_BITMAP_SET(node, i);
13982                 }
13983             }
13984         }
13985         invlist_iterfinish(*invlist_ptr);
13986
13987         /* Done with loop; remove any code points that are in the bitmap from
13988          * *invlist_ptr; similarly for code points above the bitmap if we have
13989          * a flag to match all of them anyways */
13990         if (change_invlist) {
13991             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13992         }
13993         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13994             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13995         }
13996
13997         /* If have completely emptied it, remove it completely */
13998         if (_invlist_len(*invlist_ptr) == 0) {
13999             SvREFCNT_dec_NN(*invlist_ptr);
14000             *invlist_ptr = NULL;
14001         }
14002     }
14003 }
14004
14005 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
14006    Character classes ([:foo:]) can also be negated ([:^foo:]).
14007    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
14008    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
14009    but trigger failures because they are currently unimplemented. */
14010
14011 #define POSIXCC_DONE(c)   ((c) == ':')
14012 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
14013 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
14014 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
14015
14016 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
14017 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
14018 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
14019
14020 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
14021
14022 /* 'posix_warnings' and 'warn_text' are names of variables in the following
14023  * routine. q.v. */
14024 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
14025         if (posix_warnings) {                                               \
14026             if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
14027             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                          \
14028                                              WARNING_PREFIX                 \
14029                                              text                           \
14030                                              REPORT_LOCATION,               \
14031                                              REPORT_LOCATION_ARGS(p)));     \
14032         }                                                                   \
14033     } STMT_END
14034 #define CLEAR_POSIX_WARNINGS()                                              \
14035     STMT_START {                                                            \
14036         if (posix_warnings && RExC_warn_text)                               \
14037             av_clear(RExC_warn_text);                                       \
14038     } STMT_END
14039
14040 #define CLEAR_POSIX_WARNINGS_AND_RETURN(ret)                                \
14041     STMT_START {                                                            \
14042         CLEAR_POSIX_WARNINGS();                                             \
14043         return ret;                                                         \
14044     } STMT_END
14045
14046 STATIC int
14047 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
14048
14049     const char * const s,      /* Where the putative posix class begins.
14050                                   Normally, this is one past the '['.  This
14051                                   parameter exists so it can be somewhere
14052                                   besides RExC_parse. */
14053     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
14054                                   NULL */
14055     AV ** posix_warnings,      /* Where to place any generated warnings, or
14056                                   NULL */
14057     const bool check_only      /* Don't die if error */
14058 )
14059 {
14060     /* This parses what the caller thinks may be one of the three POSIX
14061      * constructs:
14062      *  1) a character class, like [:blank:]
14063      *  2) a collating symbol, like [. .]
14064      *  3) an equivalence class, like [= =]
14065      * In the latter two cases, it croaks if it finds a syntactically legal
14066      * one, as these are not handled by Perl.
14067      *
14068      * The main purpose is to look for a POSIX character class.  It returns:
14069      *  a) the class number
14070      *      if it is a completely syntactically and semantically legal class.
14071      *      'updated_parse_ptr', if not NULL, is set to point to just after the
14072      *      closing ']' of the class
14073      *  b) OOB_NAMEDCLASS
14074      *      if it appears that one of the three POSIX constructs was meant, but
14075      *      its specification was somehow defective.  'updated_parse_ptr', if
14076      *      not NULL, is set to point to the character just after the end
14077      *      character of the class.  See below for handling of warnings.
14078      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
14079      *      if it  doesn't appear that a POSIX construct was intended.
14080      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
14081      *      raised.
14082      *
14083      * In b) there may be errors or warnings generated.  If 'check_only' is
14084      * TRUE, then any errors are discarded.  Warnings are returned to the
14085      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
14086      * instead it is NULL, warnings are suppressed.  This is done in all
14087      * passes.  The reason for this is that the rest of the parsing is heavily
14088      * dependent on whether this routine found a valid posix class or not.  If
14089      * it did, the closing ']' is absorbed as part of the class.  If no class,
14090      * or an invalid one is found, any ']' will be considered the terminator of
14091      * the outer bracketed character class, leading to very different results.
14092      * In particular, a '(?[ ])' construct will likely have a syntax error if
14093      * the class is parsed other than intended, and this will happen in pass1,
14094      * before the warnings would normally be output.  This mechanism allows the
14095      * caller to output those warnings in pass1 just before dieing, giving a
14096      * much better clue as to what is wrong.
14097      *
14098      * The reason for this function, and its complexity is that a bracketed
14099      * character class can contain just about anything.  But it's easy to
14100      * mistype the very specific posix class syntax but yielding a valid
14101      * regular bracketed class, so it silently gets compiled into something
14102      * quite unintended.
14103      *
14104      * The solution adopted here maintains backward compatibility except that
14105      * it adds a warning if it looks like a posix class was intended but
14106      * improperly specified.  The warning is not raised unless what is input
14107      * very closely resembles one of the 14 legal posix classes.  To do this,
14108      * it uses fuzzy parsing.  It calculates how many single-character edits it
14109      * would take to transform what was input into a legal posix class.  Only
14110      * if that number is quite small does it think that the intention was a
14111      * posix class.  Obviously these are heuristics, and there will be cases
14112      * where it errs on one side or another, and they can be tweaked as
14113      * experience informs.
14114      *
14115      * The syntax for a legal posix class is:
14116      *
14117      * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
14118      *
14119      * What this routine considers syntactically to be an intended posix class
14120      * is this (the comments indicate some restrictions that the pattern
14121      * doesn't show):
14122      *
14123      *  qr/(?x: \[?                         # The left bracket, possibly
14124      *                                      # omitted
14125      *          \h*                         # possibly followed by blanks
14126      *          (?: \^ \h* )?               # possibly a misplaced caret
14127      *          [:;]?                       # The opening class character,
14128      *                                      # possibly omitted.  A typo
14129      *                                      # semi-colon can also be used.
14130      *          \h*
14131      *          \^?                         # possibly a correctly placed
14132      *                                      # caret, but not if there was also
14133      *                                      # a misplaced one
14134      *          \h*
14135      *          .{3,15}                     # The class name.  If there are
14136      *                                      # deviations from the legal syntax,
14137      *                                      # its edit distance must be close
14138      *                                      # to a real class name in order
14139      *                                      # for it to be considered to be
14140      *                                      # an intended posix class.
14141      *          \h*
14142      *          [[:punct:]]?                # The closing class character,
14143      *                                      # possibly omitted.  If not a colon
14144      *                                      # nor semi colon, the class name
14145      *                                      # must be even closer to a valid
14146      *                                      # one
14147      *          \h*
14148      *          \]?                         # The right bracket, possibly
14149      *                                      # omitted.
14150      *     )/
14151      *
14152      * In the above, \h must be ASCII-only.
14153      *
14154      * These are heuristics, and can be tweaked as field experience dictates.
14155      * There will be cases when someone didn't intend to specify a posix class
14156      * that this warns as being so.  The goal is to minimize these, while
14157      * maximizing the catching of things intended to be a posix class that
14158      * aren't parsed as such.
14159      */
14160
14161     const char* p             = s;
14162     const char * const e      = RExC_end;
14163     unsigned complement       = 0;      /* If to complement the class */
14164     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
14165     bool has_opening_bracket  = FALSE;
14166     bool has_opening_colon    = FALSE;
14167     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
14168                                                    valid class */
14169     const char * possible_end = NULL;   /* used for a 2nd parse pass */
14170     const char* name_start;             /* ptr to class name first char */
14171
14172     /* If the number of single-character typos the input name is away from a
14173      * legal name is no more than this number, it is considered to have meant
14174      * the legal name */
14175     int max_distance          = 2;
14176
14177     /* to store the name.  The size determines the maximum length before we
14178      * decide that no posix class was intended.  Should be at least
14179      * sizeof("alphanumeric") */
14180     UV input_text[15];
14181     STATIC_ASSERT_DECL(C_ARRAY_LENGTH(input_text) >= sizeof "alphanumeric");
14182
14183     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
14184
14185     CLEAR_POSIX_WARNINGS();
14186
14187     if (p >= e) {
14188         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14189     }
14190
14191     if (*(p - 1) != '[') {
14192         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
14193         found_problem = TRUE;
14194     }
14195     else {
14196         has_opening_bracket = TRUE;
14197     }
14198
14199     /* They could be confused and think you can put spaces between the
14200      * components */
14201     if (isBLANK(*p)) {
14202         found_problem = TRUE;
14203
14204         do {
14205             p++;
14206         } while (p < e && isBLANK(*p));
14207
14208         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14209     }
14210
14211     /* For [. .] and [= =].  These are quite different internally from [: :],
14212      * so they are handled separately.  */
14213     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
14214                                             and 1 for at least one char in it
14215                                           */
14216     {
14217         const char open_char  = *p;
14218         const char * temp_ptr = p + 1;
14219
14220         /* These two constructs are not handled by perl, and if we find a
14221          * syntactically valid one, we croak.  khw, who wrote this code, finds
14222          * this explanation of them very unclear:
14223          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
14224          * And searching the rest of the internet wasn't very helpful either.
14225          * It looks like just about any byte can be in these constructs,
14226          * depending on the locale.  But unless the pattern is being compiled
14227          * under /l, which is very rare, Perl runs under the C or POSIX locale.
14228          * In that case, it looks like [= =] isn't allowed at all, and that
14229          * [. .] could be any single code point, but for longer strings the
14230          * constituent characters would have to be the ASCII alphabetics plus
14231          * the minus-hyphen.  Any sensible locale definition would limit itself
14232          * to these.  And any portable one definitely should.  Trying to parse
14233          * the general case is a nightmare (see [perl #127604]).  So, this code
14234          * looks only for interiors of these constructs that match:
14235          *      qr/.|[-\w]{2,}/
14236          * Using \w relaxes the apparent rules a little, without adding much
14237          * danger of mistaking something else for one of these constructs.
14238          *
14239          * [. .] in some implementations described on the internet is usable to
14240          * escape a character that otherwise is special in bracketed character
14241          * classes.  For example [.].] means a literal right bracket instead of
14242          * the ending of the class
14243          *
14244          * [= =] can legitimately contain a [. .] construct, but we don't
14245          * handle this case, as that [. .] construct will later get parsed
14246          * itself and croak then.  And [= =] is checked for even when not under
14247          * /l, as Perl has long done so.
14248          *
14249          * The code below relies on there being a trailing NUL, so it doesn't
14250          * have to keep checking if the parse ptr < e.
14251          */
14252         if (temp_ptr[1] == open_char) {
14253             temp_ptr++;
14254         }
14255         else while (    temp_ptr < e
14256                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
14257         {
14258             temp_ptr++;
14259         }
14260
14261         if (*temp_ptr == open_char) {
14262             temp_ptr++;
14263             if (*temp_ptr == ']') {
14264                 temp_ptr++;
14265                 if (! found_problem && ! check_only) {
14266                     RExC_parse = (char *) temp_ptr;
14267                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
14268                             "extensions", open_char, open_char);
14269                 }
14270
14271                 /* Here, the syntax wasn't completely valid, or else the call
14272                  * is to check-only */
14273                 if (updated_parse_ptr) {
14274                     *updated_parse_ptr = (char *) temp_ptr;
14275                 }
14276
14277                 CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
14278             }
14279         }
14280
14281         /* If we find something that started out to look like one of these
14282          * constructs, but isn't, we continue below so that it can be checked
14283          * for being a class name with a typo of '.' or '=' instead of a colon.
14284          * */
14285     }
14286
14287     /* Here, we think there is a possibility that a [: :] class was meant, and
14288      * we have the first real character.  It could be they think the '^' comes
14289      * first */
14290     if (*p == '^') {
14291         found_problem = TRUE;
14292         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
14293         complement = 1;
14294         p++;
14295
14296         if (isBLANK(*p)) {
14297             found_problem = TRUE;
14298
14299             do {
14300                 p++;
14301             } while (p < e && isBLANK(*p));
14302
14303             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14304         }
14305     }
14306
14307     /* But the first character should be a colon, which they could have easily
14308      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
14309      * distinguish from a colon, so treat that as a colon).  */
14310     if (*p == ':') {
14311         p++;
14312         has_opening_colon = TRUE;
14313     }
14314     else if (*p == ';') {
14315         found_problem = TRUE;
14316         p++;
14317         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14318         has_opening_colon = TRUE;
14319     }
14320     else {
14321         found_problem = TRUE;
14322         ADD_POSIX_WARNING(p, "there must be a starting ':'");
14323
14324         /* Consider an initial punctuation (not one of the recognized ones) to
14325          * be a left terminator */
14326         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
14327             p++;
14328         }
14329     }
14330
14331     /* They may think that you can put spaces between the components */
14332     if (isBLANK(*p)) {
14333         found_problem = TRUE;
14334
14335         do {
14336             p++;
14337         } while (p < e && isBLANK(*p));
14338
14339         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14340     }
14341
14342     if (*p == '^') {
14343
14344         /* We consider something like [^:^alnum:]] to not have been intended to
14345          * be a posix class, but XXX maybe we should */
14346         if (complement) {
14347             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14348         }
14349
14350         complement = 1;
14351         p++;
14352     }
14353
14354     /* Again, they may think that you can put spaces between the components */
14355     if (isBLANK(*p)) {
14356         found_problem = TRUE;
14357
14358         do {
14359             p++;
14360         } while (p < e && isBLANK(*p));
14361
14362         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14363     }
14364
14365     if (*p == ']') {
14366
14367         /* XXX This ']' may be a typo, and something else was meant.  But
14368          * treating it as such creates enough complications, that that
14369          * possibility isn't currently considered here.  So we assume that the
14370          * ']' is what is intended, and if we've already found an initial '[',
14371          * this leaves this construct looking like [:] or [:^], which almost
14372          * certainly weren't intended to be posix classes */
14373         if (has_opening_bracket) {
14374             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14375         }
14376
14377         /* But this function can be called when we parse the colon for
14378          * something like qr/[alpha:]]/, so we back up to look for the
14379          * beginning */
14380         p--;
14381
14382         if (*p == ';') {
14383             found_problem = TRUE;
14384             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14385         }
14386         else if (*p != ':') {
14387
14388             /* XXX We are currently very restrictive here, so this code doesn't
14389              * consider the possibility that, say, /[alpha.]]/ was intended to
14390              * be a posix class. */
14391             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14392         }
14393
14394         /* Here we have something like 'foo:]'.  There was no initial colon,
14395          * and we back up over 'foo.  XXX Unlike the going forward case, we
14396          * don't handle typos of non-word chars in the middle */
14397         has_opening_colon = FALSE;
14398         p--;
14399
14400         while (p > RExC_start && isWORDCHAR(*p)) {
14401             p--;
14402         }
14403         p++;
14404
14405         /* Here, we have positioned ourselves to where we think the first
14406          * character in the potential class is */
14407     }
14408
14409     /* Now the interior really starts.  There are certain key characters that
14410      * can end the interior, or these could just be typos.  To catch both
14411      * cases, we may have to do two passes.  In the first pass, we keep on
14412      * going unless we come to a sequence that matches
14413      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14414      * This means it takes a sequence to end the pass, so two typos in a row if
14415      * that wasn't what was intended.  If the class is perfectly formed, just
14416      * this one pass is needed.  We also stop if there are too many characters
14417      * being accumulated, but this number is deliberately set higher than any
14418      * real class.  It is set high enough so that someone who thinks that
14419      * 'alphanumeric' is a correct name would get warned that it wasn't.
14420      * While doing the pass, we keep track of where the key characters were in
14421      * it.  If we don't find an end to the class, and one of the key characters
14422      * was found, we redo the pass, but stop when we get to that character.
14423      * Thus the key character was considered a typo in the first pass, but a
14424      * terminator in the second.  If two key characters are found, we stop at
14425      * the second one in the first pass.  Again this can miss two typos, but
14426      * catches a single one
14427      *
14428      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14429      * point to the first key character.  For the second pass, it starts as -1.
14430      * */
14431
14432     name_start = p;
14433   parse_name:
14434     {
14435         bool has_blank               = FALSE;
14436         bool has_upper               = FALSE;
14437         bool has_terminating_colon   = FALSE;
14438         bool has_terminating_bracket = FALSE;
14439         bool has_semi_colon          = FALSE;
14440         unsigned int name_len        = 0;
14441         int punct_count              = 0;
14442
14443         while (p < e) {
14444
14445             /* Squeeze out blanks when looking up the class name below */
14446             if (isBLANK(*p) ) {
14447                 has_blank = TRUE;
14448                 found_problem = TRUE;
14449                 p++;
14450                 continue;
14451             }
14452
14453             /* The name will end with a punctuation */
14454             if (isPUNCT(*p)) {
14455                 const char * peek = p + 1;
14456
14457                 /* Treat any non-']' punctuation followed by a ']' (possibly
14458                  * with intervening blanks) as trying to terminate the class.
14459                  * ']]' is very likely to mean a class was intended (but
14460                  * missing the colon), but the warning message that gets
14461                  * generated shows the error position better if we exit the
14462                  * loop at the bottom (eventually), so skip it here. */
14463                 if (*p != ']') {
14464                     if (peek < e && isBLANK(*peek)) {
14465                         has_blank = TRUE;
14466                         found_problem = TRUE;
14467                         do {
14468                             peek++;
14469                         } while (peek < e && isBLANK(*peek));
14470                     }
14471
14472                     if (peek < e && *peek == ']') {
14473                         has_terminating_bracket = TRUE;
14474                         if (*p == ':') {
14475                             has_terminating_colon = TRUE;
14476                         }
14477                         else if (*p == ';') {
14478                             has_semi_colon = TRUE;
14479                             has_terminating_colon = TRUE;
14480                         }
14481                         else {
14482                             found_problem = TRUE;
14483                         }
14484                         p = peek + 1;
14485                         goto try_posix;
14486                     }
14487                 }
14488
14489                 /* Here we have punctuation we thought didn't end the class.
14490                  * Keep track of the position of the key characters that are
14491                  * more likely to have been class-enders */
14492                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14493
14494                     /* Allow just one such possible class-ender not actually
14495                      * ending the class. */
14496                     if (possible_end) {
14497                         break;
14498                     }
14499                     possible_end = p;
14500                 }
14501
14502                 /* If we have too many punctuation characters, no use in
14503                  * keeping going */
14504                 if (++punct_count > max_distance) {
14505                     break;
14506                 }
14507
14508                 /* Treat the punctuation as a typo. */
14509                 input_text[name_len++] = *p;
14510                 p++;
14511             }
14512             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14513                 input_text[name_len++] = toLOWER(*p);
14514                 has_upper = TRUE;
14515                 found_problem = TRUE;
14516                 p++;
14517             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14518                 input_text[name_len++] = *p;
14519                 p++;
14520             }
14521             else {
14522                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14523                 p+= UTF8SKIP(p);
14524             }
14525
14526             /* The declaration of 'input_text' is how long we allow a potential
14527              * class name to be, before saying they didn't mean a class name at
14528              * all */
14529             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14530                 break;
14531             }
14532         }
14533
14534         /* We get to here when the possible class name hasn't been properly
14535          * terminated before:
14536          *   1) we ran off the end of the pattern; or
14537          *   2) found two characters, each of which might have been intended to
14538          *      be the name's terminator
14539          *   3) found so many punctuation characters in the purported name,
14540          *      that the edit distance to a valid one is exceeded
14541          *   4) we decided it was more characters than anyone could have
14542          *      intended to be one. */
14543
14544         found_problem = TRUE;
14545
14546         /* In the final two cases, we know that looking up what we've
14547          * accumulated won't lead to a match, even a fuzzy one. */
14548         if (   name_len >= C_ARRAY_LENGTH(input_text)
14549             || punct_count > max_distance)
14550         {
14551             /* If there was an intermediate key character that could have been
14552              * an intended end, redo the parse, but stop there */
14553             if (possible_end && possible_end != (char *) -1) {
14554                 possible_end = (char *) -1; /* Special signal value to say
14555                                                we've done a first pass */
14556                 p = name_start;
14557                 goto parse_name;
14558             }
14559
14560             /* Otherwise, it can't have meant to have been a class */
14561             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14562         }
14563
14564         /* If we ran off the end, and the final character was a punctuation
14565          * one, back up one, to look at that final one just below.  Later, we
14566          * will restore the parse pointer if appropriate */
14567         if (name_len && p == e && isPUNCT(*(p-1))) {
14568             p--;
14569             name_len--;
14570         }
14571
14572         if (p < e && isPUNCT(*p)) {
14573             if (*p == ']') {
14574                 has_terminating_bracket = TRUE;
14575
14576                 /* If this is a 2nd ']', and the first one is just below this
14577                  * one, consider that to be the real terminator.  This gives a
14578                  * uniform and better positioning for the warning message  */
14579                 if (   possible_end
14580                     && possible_end != (char *) -1
14581                     && *possible_end == ']'
14582                     && name_len && input_text[name_len - 1] == ']')
14583                 {
14584                     name_len--;
14585                     p = possible_end;
14586
14587                     /* And this is actually equivalent to having done the 2nd
14588                      * pass now, so set it to not try again */
14589                     possible_end = (char *) -1;
14590                 }
14591             }
14592             else {
14593                 if (*p == ':') {
14594                     has_terminating_colon = TRUE;
14595                 }
14596                 else if (*p == ';') {
14597                     has_semi_colon = TRUE;
14598                     has_terminating_colon = TRUE;
14599                 }
14600                 p++;
14601             }
14602         }
14603
14604     try_posix:
14605
14606         /* Here, we have a class name to look up.  We can short circuit the
14607          * stuff below for short names that can't possibly be meant to be a
14608          * class name.  (We can do this on the first pass, as any second pass
14609          * will yield an even shorter name) */
14610         if (name_len < 3) {
14611             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14612         }
14613
14614         /* Find which class it is.  Initially switch on the length of the name.
14615          * */
14616         switch (name_len) {
14617             case 4:
14618                 if (memEQ(name_start, "word", 4)) {
14619                     /* this is not POSIX, this is the Perl \w */
14620                     class_number = ANYOF_WORDCHAR;
14621                 }
14622                 break;
14623             case 5:
14624                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14625                  *                        graph lower print punct space upper
14626                  * Offset 4 gives the best switch position.  */
14627                 switch (name_start[4]) {
14628                     case 'a':
14629                         if (memEQ(name_start, "alph", 4)) /* alpha */
14630                             class_number = ANYOF_ALPHA;
14631                         break;
14632                     case 'e':
14633                         if (memEQ(name_start, "spac", 4)) /* space */
14634                             class_number = ANYOF_SPACE;
14635                         break;
14636                     case 'h':
14637                         if (memEQ(name_start, "grap", 4)) /* graph */
14638                             class_number = ANYOF_GRAPH;
14639                         break;
14640                     case 'i':
14641                         if (memEQ(name_start, "asci", 4)) /* ascii */
14642                             class_number = ANYOF_ASCII;
14643                         break;
14644                     case 'k':
14645                         if (memEQ(name_start, "blan", 4)) /* blank */
14646                             class_number = ANYOF_BLANK;
14647                         break;
14648                     case 'l':
14649                         if (memEQ(name_start, "cntr", 4)) /* cntrl */
14650                             class_number = ANYOF_CNTRL;
14651                         break;
14652                     case 'm':
14653                         if (memEQ(name_start, "alnu", 4)) /* alnum */
14654                             class_number = ANYOF_ALPHANUMERIC;
14655                         break;
14656                     case 'r':
14657                         if (memEQ(name_start, "lowe", 4)) /* lower */
14658                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
14659                         else if (memEQ(name_start, "uppe", 4)) /* upper */
14660                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
14661                         break;
14662                     case 't':
14663                         if (memEQ(name_start, "digi", 4)) /* digit */
14664                             class_number = ANYOF_DIGIT;
14665                         else if (memEQ(name_start, "prin", 4)) /* print */
14666                             class_number = ANYOF_PRINT;
14667                         else if (memEQ(name_start, "punc", 4)) /* punct */
14668                             class_number = ANYOF_PUNCT;
14669                         break;
14670                 }
14671                 break;
14672             case 6:
14673                 if (memEQ(name_start, "xdigit", 6))
14674                     class_number = ANYOF_XDIGIT;
14675                 break;
14676         }
14677
14678         /* If the name exactly matches a posix class name the class number will
14679          * here be set to it, and the input almost certainly was meant to be a
14680          * posix class, so we can skip further checking.  If instead the syntax
14681          * is exactly correct, but the name isn't one of the legal ones, we
14682          * will return that as an error below.  But if neither of these apply,
14683          * it could be that no posix class was intended at all, or that one
14684          * was, but there was a typo.  We tease these apart by doing fuzzy
14685          * matching on the name */
14686         if (class_number == OOB_NAMEDCLASS && found_problem) {
14687             const UV posix_names[][6] = {
14688                                                 { 'a', 'l', 'n', 'u', 'm' },
14689                                                 { 'a', 'l', 'p', 'h', 'a' },
14690                                                 { 'a', 's', 'c', 'i', 'i' },
14691                                                 { 'b', 'l', 'a', 'n', 'k' },
14692                                                 { 'c', 'n', 't', 'r', 'l' },
14693                                                 { 'd', 'i', 'g', 'i', 't' },
14694                                                 { 'g', 'r', 'a', 'p', 'h' },
14695                                                 { 'l', 'o', 'w', 'e', 'r' },
14696                                                 { 'p', 'r', 'i', 'n', 't' },
14697                                                 { 'p', 'u', 'n', 'c', 't' },
14698                                                 { 's', 'p', 'a', 'c', 'e' },
14699                                                 { 'u', 'p', 'p', 'e', 'r' },
14700                                                 { 'w', 'o', 'r', 'd' },
14701                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
14702                                             };
14703             /* The names of the above all have added NULs to make them the same
14704              * size, so we need to also have the real lengths */
14705             const UV posix_name_lengths[] = {
14706                                                 sizeof("alnum") - 1,
14707                                                 sizeof("alpha") - 1,
14708                                                 sizeof("ascii") - 1,
14709                                                 sizeof("blank") - 1,
14710                                                 sizeof("cntrl") - 1,
14711                                                 sizeof("digit") - 1,
14712                                                 sizeof("graph") - 1,
14713                                                 sizeof("lower") - 1,
14714                                                 sizeof("print") - 1,
14715                                                 sizeof("punct") - 1,
14716                                                 sizeof("space") - 1,
14717                                                 sizeof("upper") - 1,
14718                                                 sizeof("word")  - 1,
14719                                                 sizeof("xdigit")- 1
14720                                             };
14721             unsigned int i;
14722             int temp_max = max_distance;    /* Use a temporary, so if we
14723                                                reparse, we haven't changed the
14724                                                outer one */
14725
14726             /* Use a smaller max edit distance if we are missing one of the
14727              * delimiters */
14728             if (   has_opening_bracket + has_opening_colon < 2
14729                 || has_terminating_bracket + has_terminating_colon < 2)
14730             {
14731                 temp_max--;
14732             }
14733
14734             /* See if the input name is close to a legal one */
14735             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
14736
14737                 /* Short circuit call if the lengths are too far apart to be
14738                  * able to match */
14739                 if (abs( (int) (name_len - posix_name_lengths[i]))
14740                     > temp_max)
14741                 {
14742                     continue;
14743                 }
14744
14745                 if (edit_distance(input_text,
14746                                   posix_names[i],
14747                                   name_len,
14748                                   posix_name_lengths[i],
14749                                   temp_max
14750                                  )
14751                     > -1)
14752                 { /* If it is close, it probably was intended to be a class */
14753                     goto probably_meant_to_be;
14754                 }
14755             }
14756
14757             /* Here the input name is not close enough to a valid class name
14758              * for us to consider it to be intended to be a posix class.  If
14759              * we haven't already done so, and the parse found a character that
14760              * could have been terminators for the name, but which we absorbed
14761              * as typos during the first pass, repeat the parse, signalling it
14762              * to stop at that character */
14763             if (possible_end && possible_end != (char *) -1) {
14764                 possible_end = (char *) -1;
14765                 p = name_start;
14766                 goto parse_name;
14767             }
14768
14769             /* Here neither pass found a close-enough class name */
14770             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14771         }
14772
14773     probably_meant_to_be:
14774
14775         /* Here we think that a posix specification was intended.  Update any
14776          * parse pointer */
14777         if (updated_parse_ptr) {
14778             *updated_parse_ptr = (char *) p;
14779         }
14780
14781         /* If a posix class name was intended but incorrectly specified, we
14782          * output or return the warnings */
14783         if (found_problem) {
14784
14785             /* We set flags for these issues in the parse loop above instead of
14786              * adding them to the list of warnings, because we can parse it
14787              * twice, and we only want one warning instance */
14788             if (has_upper) {
14789                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
14790             }
14791             if (has_blank) {
14792                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14793             }
14794             if (has_semi_colon) {
14795                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14796             }
14797             else if (! has_terminating_colon) {
14798                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
14799             }
14800             if (! has_terminating_bracket) {
14801                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
14802             }
14803
14804             if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
14805                 *posix_warnings = RExC_warn_text;
14806             }
14807         }
14808         else if (class_number != OOB_NAMEDCLASS) {
14809             /* If it is a known class, return the class.  The class number
14810              * #defines are structured so each complement is +1 to the normal
14811              * one */
14812             CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
14813         }
14814         else if (! check_only) {
14815
14816             /* Here, it is an unrecognized class.  This is an error (unless the
14817             * call is to check only, which we've already handled above) */
14818             const char * const complement_string = (complement)
14819                                                    ? "^"
14820                                                    : "";
14821             RExC_parse = (char *) p;
14822             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
14823                         complement_string,
14824                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
14825         }
14826     }
14827
14828     return OOB_NAMEDCLASS;
14829 }
14830 #undef ADD_POSIX_WARNING
14831
14832 STATIC unsigned  int
14833 S_regex_set_precedence(const U8 my_operator) {
14834
14835     /* Returns the precedence in the (?[...]) construct of the input operator,
14836      * specified by its character representation.  The precedence follows
14837      * general Perl rules, but it extends this so that ')' and ']' have (low)
14838      * precedence even though they aren't really operators */
14839
14840     switch (my_operator) {
14841         case '!':
14842             return 5;
14843         case '&':
14844             return 4;
14845         case '^':
14846         case '|':
14847         case '+':
14848         case '-':
14849             return 3;
14850         case ')':
14851             return 2;
14852         case ']':
14853             return 1;
14854     }
14855
14856     NOT_REACHED; /* NOTREACHED */
14857     return 0;   /* Silence compiler warning */
14858 }
14859
14860 STATIC regnode *
14861 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
14862                     I32 *flagp, U32 depth,
14863                     char * const oregcomp_parse)
14864 {
14865     /* Handle the (?[...]) construct to do set operations */
14866
14867     U8 curchar;                     /* Current character being parsed */
14868     UV start, end;                  /* End points of code point ranges */
14869     SV* final = NULL;               /* The end result inversion list */
14870     SV* result_string;              /* 'final' stringified */
14871     AV* stack;                      /* stack of operators and operands not yet
14872                                        resolved */
14873     AV* fence_stack = NULL;         /* A stack containing the positions in
14874                                        'stack' of where the undealt-with left
14875                                        parens would be if they were actually
14876                                        put there */
14877     /* The 'volatile' is a workaround for an optimiser bug
14878      * in Solaris Studio 12.3. See RT #127455 */
14879     volatile IV fence = 0;          /* Position of where most recent undealt-
14880                                        with left paren in stack is; -1 if none.
14881                                      */
14882     STRLEN len;                     /* Temporary */
14883     regnode* node;                  /* Temporary, and final regnode returned by
14884                                        this function */
14885     const bool save_fold = FOLD;    /* Temporary */
14886     char *save_end, *save_parse;    /* Temporaries */
14887     const bool in_locale = LOC;     /* we turn off /l during processing */
14888     AV* posix_warnings = NULL;
14889
14890     GET_RE_DEBUG_FLAGS_DECL;
14891
14892     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
14893
14894     if (in_locale) {
14895         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
14896     }
14897
14898     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
14899                                          This is required so that the compile
14900                                          time values are valid in all runtime
14901                                          cases */
14902
14903     /* This will return only an ANYOF regnode, or (unlikely) something smaller
14904      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
14905      * call regclass to handle '[]' so as to not have to reinvent its parsing
14906      * rules here (throwing away the size it computes each time).  And, we exit
14907      * upon an unescaped ']' that isn't one ending a regclass.  To do both
14908      * these things, we need to realize that something preceded by a backslash
14909      * is escaped, so we have to keep track of backslashes */
14910     if (SIZE_ONLY) {
14911         UV depth = 0; /* how many nested (?[...]) constructs */
14912
14913         while (RExC_parse < RExC_end) {
14914             SV* current = NULL;
14915
14916             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14917                                     TRUE /* Force /x */ );
14918
14919             switch (*RExC_parse) {
14920                 case '?':
14921                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
14922                     /* FALLTHROUGH */
14923                 default:
14924                     break;
14925                 case '\\':
14926                     /* Skip past this, so the next character gets skipped, after
14927                      * the switch */
14928                     RExC_parse++;
14929                     if (*RExC_parse == 'c') {
14930                             /* Skip the \cX notation for control characters */
14931                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14932                     }
14933                     break;
14934
14935                 case '[':
14936                 {
14937                     /* See if this is a [:posix:] class. */
14938                     bool is_posix_class = (OOB_NAMEDCLASS
14939                             < handle_possible_posix(pRExC_state,
14940                                                 RExC_parse + 1,
14941                                                 NULL,
14942                                                 NULL,
14943                                                 TRUE /* checking only */));
14944                     /* If it is a posix class, leave the parse pointer at the
14945                      * '[' to fool regclass() into thinking it is part of a
14946                      * '[[:posix:]]'. */
14947                     if (! is_posix_class) {
14948                         RExC_parse++;
14949                     }
14950
14951                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
14952                      * if multi-char folds are allowed.  */
14953                     if (!regclass(pRExC_state, flagp,depth+1,
14954                                   is_posix_class, /* parse the whole char
14955                                                      class only if not a
14956                                                      posix class */
14957                                   FALSE, /* don't allow multi-char folds */
14958                                   TRUE, /* silence non-portable warnings. */
14959                                   TRUE, /* strict */
14960                                   FALSE, /* Require return to be an ANYOF */
14961                                   &current,
14962                                   &posix_warnings
14963                                  ))
14964                         FAIL2("panic: regclass returned NULL to handle_sets, "
14965                               "flags=%#" UVxf, (UV) *flagp);
14966
14967                     /* function call leaves parse pointing to the ']', except
14968                      * if we faked it */
14969                     if (is_posix_class) {
14970                         RExC_parse--;
14971                     }
14972
14973                     SvREFCNT_dec(current);   /* In case it returned something */
14974                     break;
14975                 }
14976
14977                 case ']':
14978                     if (depth--) break;
14979                     RExC_parse++;
14980                     if (*RExC_parse == ')') {
14981                         node = reganode(pRExC_state, ANYOF, 0);
14982                         RExC_size += ANYOF_SKIP;
14983                         nextchar(pRExC_state);
14984                         Set_Node_Length(node,
14985                                 RExC_parse - oregcomp_parse + 1); /* MJD */
14986                         if (in_locale) {
14987                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
14988                         }
14989
14990                         return node;
14991                     }
14992                     goto no_close;
14993             }
14994
14995             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14996         }
14997
14998       no_close:
14999         /* We output the messages even if warnings are off, because we'll fail
15000          * the very next thing, and these give a likely diagnosis for that */
15001         if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
15002             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
15003         }
15004
15005         FAIL("Syntax error in (?[...])");
15006     }
15007
15008     /* Pass 2 only after this. */
15009     Perl_ck_warner_d(aTHX_
15010         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
15011         "The regex_sets feature is experimental" REPORT_LOCATION,
15012         REPORT_LOCATION_ARGS(RExC_parse));
15013
15014     /* Everything in this construct is a metacharacter.  Operands begin with
15015      * either a '\' (for an escape sequence), or a '[' for a bracketed
15016      * character class.  Any other character should be an operator, or
15017      * parenthesis for grouping.  Both types of operands are handled by calling
15018      * regclass() to parse them.  It is called with a parameter to indicate to
15019      * return the computed inversion list.  The parsing here is implemented via
15020      * a stack.  Each entry on the stack is a single character representing one
15021      * of the operators; or else a pointer to an operand inversion list. */
15022
15023 #define IS_OPERATOR(a) SvIOK(a)
15024 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
15025
15026     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
15027      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
15028      * with pronouncing it called it Reverse Polish instead, but now that YOU
15029      * know how to pronounce it you can use the correct term, thus giving due
15030      * credit to the person who invented it, and impressing your geek friends.
15031      * Wikipedia says that the pronounciation of "Ł" has been changing so that
15032      * it is now more like an English initial W (as in wonk) than an L.)
15033      *
15034      * This means that, for example, 'a | b & c' is stored on the stack as
15035      *
15036      * c  [4]
15037      * b  [3]
15038      * &  [2]
15039      * a  [1]
15040      * |  [0]
15041      *
15042      * where the numbers in brackets give the stack [array] element number.
15043      * In this implementation, parentheses are not stored on the stack.
15044      * Instead a '(' creates a "fence" so that the part of the stack below the
15045      * fence is invisible except to the corresponding ')' (this allows us to
15046      * replace testing for parens, by using instead subtraction of the fence
15047      * position).  As new operands are processed they are pushed onto the stack
15048      * (except as noted in the next paragraph).  New operators of higher
15049      * precedence than the current final one are inserted on the stack before
15050      * the lhs operand (so that when the rhs is pushed next, everything will be
15051      * in the correct positions shown above.  When an operator of equal or
15052      * lower precedence is encountered in parsing, all the stacked operations
15053      * of equal or higher precedence are evaluated, leaving the result as the
15054      * top entry on the stack.  This makes higher precedence operations
15055      * evaluate before lower precedence ones, and causes operations of equal
15056      * precedence to left associate.
15057      *
15058      * The only unary operator '!' is immediately pushed onto the stack when
15059      * encountered.  When an operand is encountered, if the top of the stack is
15060      * a '!", the complement is immediately performed, and the '!' popped.  The
15061      * resulting value is treated as a new operand, and the logic in the
15062      * previous paragraph is executed.  Thus in the expression
15063      *      [a] + ! [b]
15064      * the stack looks like
15065      *
15066      * !
15067      * a
15068      * +
15069      *
15070      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
15071      * becomes
15072      *
15073      * !b
15074      * a
15075      * +
15076      *
15077      * A ')' is treated as an operator with lower precedence than all the
15078      * aforementioned ones, which causes all operations on the stack above the
15079      * corresponding '(' to be evaluated down to a single resultant operand.
15080      * Then the fence for the '(' is removed, and the operand goes through the
15081      * algorithm above, without the fence.
15082      *
15083      * A separate stack is kept of the fence positions, so that the position of
15084      * the latest so-far unbalanced '(' is at the top of it.
15085      *
15086      * The ']' ending the construct is treated as the lowest operator of all,
15087      * so that everything gets evaluated down to a single operand, which is the
15088      * result */
15089
15090     sv_2mortal((SV *)(stack = newAV()));
15091     sv_2mortal((SV *)(fence_stack = newAV()));
15092
15093     while (RExC_parse < RExC_end) {
15094         I32 top_index;              /* Index of top-most element in 'stack' */
15095         SV** top_ptr;               /* Pointer to top 'stack' element */
15096         SV* current = NULL;         /* To contain the current inversion list
15097                                        operand */
15098         SV* only_to_avoid_leaks;
15099
15100         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15101                                 TRUE /* Force /x */ );
15102         if (RExC_parse >= RExC_end) {
15103             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
15104         }
15105
15106         curchar = UCHARAT(RExC_parse);
15107
15108 redo_curchar:
15109
15110 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15111                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
15112         DEBUG_U(dump_regex_sets_structures(pRExC_state,
15113                                            stack, fence, fence_stack));
15114 #endif
15115
15116         top_index = av_tindex_skip_len_mg(stack);
15117
15118         switch (curchar) {
15119             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
15120             char stacked_operator;  /* The topmost operator on the 'stack'. */
15121             SV* lhs;                /* Operand to the left of the operator */
15122             SV* rhs;                /* Operand to the right of the operator */
15123             SV* fence_ptr;          /* Pointer to top element of the fence
15124                                        stack */
15125
15126             case '(':
15127
15128                 if (   RExC_parse < RExC_end - 1
15129                     && (UCHARAT(RExC_parse + 1) == '?'))
15130                 {
15131                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
15132                      * This happens when we have some thing like
15133                      *
15134                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
15135                      *   ...
15136                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
15137                      *
15138                      * Here we would be handling the interpolated
15139                      * '$thai_or_lao'.  We handle this by a recursive call to
15140                      * ourselves which returns the inversion list the
15141                      * interpolated expression evaluates to.  We use the flags
15142                      * from the interpolated pattern. */
15143                     U32 save_flags = RExC_flags;
15144                     const char * save_parse;
15145
15146                     RExC_parse += 2;        /* Skip past the '(?' */
15147                     save_parse = RExC_parse;
15148
15149                     /* Parse any flags for the '(?' */
15150                     parse_lparen_question_flags(pRExC_state);
15151
15152                     if (RExC_parse == save_parse  /* Makes sure there was at
15153                                                      least one flag (or else
15154                                                      this embedding wasn't
15155                                                      compiled) */
15156                         || RExC_parse >= RExC_end - 4
15157                         || UCHARAT(RExC_parse) != ':'
15158                         || UCHARAT(++RExC_parse) != '('
15159                         || UCHARAT(++RExC_parse) != '?'
15160                         || UCHARAT(++RExC_parse) != '[')
15161                     {
15162
15163                         /* In combination with the above, this moves the
15164                          * pointer to the point just after the first erroneous
15165                          * character (or if there are no flags, to where they
15166                          * should have been) */
15167                         if (RExC_parse >= RExC_end - 4) {
15168                             RExC_parse = RExC_end;
15169                         }
15170                         else if (RExC_parse != save_parse) {
15171                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15172                         }
15173                         vFAIL("Expecting '(?flags:(?[...'");
15174                     }
15175
15176                     /* Recurse, with the meat of the embedded expression */
15177                     RExC_parse++;
15178                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15179                                                     depth+1, oregcomp_parse);
15180
15181                     /* Here, 'current' contains the embedded expression's
15182                      * inversion list, and RExC_parse points to the trailing
15183                      * ']'; the next character should be the ')' */
15184                     RExC_parse++;
15185                     assert(UCHARAT(RExC_parse) == ')');
15186
15187                     /* Then the ')' matching the original '(' handled by this
15188                      * case: statement */
15189                     RExC_parse++;
15190                     assert(UCHARAT(RExC_parse) == ')');
15191
15192                     RExC_parse++;
15193                     RExC_flags = save_flags;
15194                     goto handle_operand;
15195                 }
15196
15197                 /* A regular '('.  Look behind for illegal syntax */
15198                 if (top_index - fence >= 0) {
15199                     /* If the top entry on the stack is an operator, it had
15200                      * better be a '!', otherwise the entry below the top
15201                      * operand should be an operator */
15202                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15203                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15204                         || (   IS_OPERAND(*top_ptr)
15205                             && (   top_index - fence < 1
15206                                 || ! (stacked_ptr = av_fetch(stack,
15207                                                              top_index - 1,
15208                                                              FALSE))
15209                                 || ! IS_OPERATOR(*stacked_ptr))))
15210                     {
15211                         RExC_parse++;
15212                         vFAIL("Unexpected '(' with no preceding operator");
15213                     }
15214                 }
15215
15216                 /* Stack the position of this undealt-with left paren */
15217                 av_push(fence_stack, newSViv(fence));
15218                 fence = top_index + 1;
15219                 break;
15220
15221             case '\\':
15222                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15223                  * multi-char folds are allowed.  */
15224                 if (!regclass(pRExC_state, flagp,depth+1,
15225                               TRUE, /* means parse just the next thing */
15226                               FALSE, /* don't allow multi-char folds */
15227                               FALSE, /* don't silence non-portable warnings.  */
15228                               TRUE,  /* strict */
15229                               FALSE, /* Require return to be an ANYOF */
15230                               &current,
15231                               NULL))
15232                 {
15233                     FAIL2("panic: regclass returned NULL to handle_sets, "
15234                           "flags=%#" UVxf, (UV) *flagp);
15235                 }
15236
15237                 /* regclass() will return with parsing just the \ sequence,
15238                  * leaving the parse pointer at the next thing to parse */
15239                 RExC_parse--;
15240                 goto handle_operand;
15241
15242             case '[':   /* Is a bracketed character class */
15243             {
15244                 /* See if this is a [:posix:] class. */
15245                 bool is_posix_class = (OOB_NAMEDCLASS
15246                             < handle_possible_posix(pRExC_state,
15247                                                 RExC_parse + 1,
15248                                                 NULL,
15249                                                 NULL,
15250                                                 TRUE /* checking only */));
15251                 /* If it is a posix class, leave the parse pointer at the '['
15252                  * to fool regclass() into thinking it is part of a
15253                  * '[[:posix:]]'. */
15254                 if (! is_posix_class) {
15255                     RExC_parse++;
15256                 }
15257
15258                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15259                  * multi-char folds are allowed.  */
15260                 if (!regclass(pRExC_state, flagp,depth+1,
15261                                 is_posix_class, /* parse the whole char
15262                                                     class only if not a
15263                                                     posix class */
15264                                 FALSE, /* don't allow multi-char folds */
15265                                 TRUE, /* silence non-portable warnings. */
15266                                 TRUE, /* strict */
15267                                 FALSE, /* Require return to be an ANYOF */
15268                                 &current,
15269                                 NULL
15270                                 ))
15271                 {
15272                     FAIL2("panic: regclass returned NULL to handle_sets, "
15273                           "flags=%#" UVxf, (UV) *flagp);
15274                 }
15275
15276                 /* function call leaves parse pointing to the ']', except if we
15277                  * faked it */
15278                 if (is_posix_class) {
15279                     RExC_parse--;
15280                 }
15281
15282                 goto handle_operand;
15283             }
15284
15285             case ']':
15286                 if (top_index >= 1) {
15287                     goto join_operators;
15288                 }
15289
15290                 /* Only a single operand on the stack: are done */
15291                 goto done;
15292
15293             case ')':
15294                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
15295                     RExC_parse++;
15296                     vFAIL("Unexpected ')'");
15297                 }
15298
15299                 /* If nothing after the fence, is missing an operand */
15300                 if (top_index - fence < 0) {
15301                     RExC_parse++;
15302                     goto bad_syntax;
15303                 }
15304                 /* If at least two things on the stack, treat this as an
15305                   * operator */
15306                 if (top_index - fence >= 1) {
15307                     goto join_operators;
15308                 }
15309
15310                 /* Here only a single thing on the fenced stack, and there is a
15311                  * fence.  Get rid of it */
15312                 fence_ptr = av_pop(fence_stack);
15313                 assert(fence_ptr);
15314                 fence = SvIV(fence_ptr) - 1;
15315                 SvREFCNT_dec_NN(fence_ptr);
15316                 fence_ptr = NULL;
15317
15318                 if (fence < 0) {
15319                     fence = 0;
15320                 }
15321
15322                 /* Having gotten rid of the fence, we pop the operand at the
15323                  * stack top and process it as a newly encountered operand */
15324                 current = av_pop(stack);
15325                 if (IS_OPERAND(current)) {
15326                     goto handle_operand;
15327                 }
15328
15329                 RExC_parse++;
15330                 goto bad_syntax;
15331
15332             case '&':
15333             case '|':
15334             case '+':
15335             case '-':
15336             case '^':
15337
15338                 /* These binary operators should have a left operand already
15339                  * parsed */
15340                 if (   top_index - fence < 0
15341                     || top_index - fence == 1
15342                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15343                     || ! IS_OPERAND(*top_ptr))
15344                 {
15345                     goto unexpected_binary;
15346                 }
15347
15348                 /* If only the one operand is on the part of the stack visible
15349                  * to us, we just place this operator in the proper position */
15350                 if (top_index - fence < 2) {
15351
15352                     /* Place the operator before the operand */
15353
15354                     SV* lhs = av_pop(stack);
15355                     av_push(stack, newSVuv(curchar));
15356                     av_push(stack, lhs);
15357                     break;
15358                 }
15359
15360                 /* But if there is something else on the stack, we need to
15361                  * process it before this new operator if and only if the
15362                  * stacked operation has equal or higher precedence than the
15363                  * new one */
15364
15365              join_operators:
15366
15367                 /* The operator on the stack is supposed to be below both its
15368                  * operands */
15369                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15370                     || IS_OPERAND(*stacked_ptr))
15371                 {
15372                     /* But if not, it's legal and indicates we are completely
15373                      * done if and only if we're currently processing a ']',
15374                      * which should be the final thing in the expression */
15375                     if (curchar == ']') {
15376                         goto done;
15377                     }
15378
15379                   unexpected_binary:
15380                     RExC_parse++;
15381                     vFAIL2("Unexpected binary operator '%c' with no "
15382                            "preceding operand", curchar);
15383                 }
15384                 stacked_operator = (char) SvUV(*stacked_ptr);
15385
15386                 if (regex_set_precedence(curchar)
15387                     > regex_set_precedence(stacked_operator))
15388                 {
15389                     /* Here, the new operator has higher precedence than the
15390                      * stacked one.  This means we need to add the new one to
15391                      * the stack to await its rhs operand (and maybe more
15392                      * stuff).  We put it before the lhs operand, leaving
15393                      * untouched the stacked operator and everything below it
15394                      * */
15395                     lhs = av_pop(stack);
15396                     assert(IS_OPERAND(lhs));
15397
15398                     av_push(stack, newSVuv(curchar));
15399                     av_push(stack, lhs);
15400                     break;
15401                 }
15402
15403                 /* Here, the new operator has equal or lower precedence than
15404                  * what's already there.  This means the operation already
15405                  * there should be performed now, before the new one. */
15406
15407                 rhs = av_pop(stack);
15408                 if (! IS_OPERAND(rhs)) {
15409
15410                     /* This can happen when a ! is not followed by an operand,
15411                      * like in /(?[\t &!])/ */
15412                     goto bad_syntax;
15413                 }
15414
15415                 lhs = av_pop(stack);
15416
15417                 if (! IS_OPERAND(lhs)) {
15418
15419                     /* This can happen when there is an empty (), like in
15420                      * /(?[[0]+()+])/ */
15421                     goto bad_syntax;
15422                 }
15423
15424                 switch (stacked_operator) {
15425                     case '&':
15426                         _invlist_intersection(lhs, rhs, &rhs);
15427                         break;
15428
15429                     case '|':
15430                     case '+':
15431                         _invlist_union(lhs, rhs, &rhs);
15432                         break;
15433
15434                     case '-':
15435                         _invlist_subtract(lhs, rhs, &rhs);
15436                         break;
15437
15438                     case '^':   /* The union minus the intersection */
15439                     {
15440                         SV* i = NULL;
15441                         SV* u = NULL;
15442
15443                         _invlist_union(lhs, rhs, &u);
15444                         _invlist_intersection(lhs, rhs, &i);
15445                         _invlist_subtract(u, i, &rhs);
15446                         SvREFCNT_dec_NN(i);
15447                         SvREFCNT_dec_NN(u);
15448                         break;
15449                     }
15450                 }
15451                 SvREFCNT_dec(lhs);
15452
15453                 /* Here, the higher precedence operation has been done, and the
15454                  * result is in 'rhs'.  We overwrite the stacked operator with
15455                  * the result.  Then we redo this code to either push the new
15456                  * operator onto the stack or perform any higher precedence
15457                  * stacked operation */
15458                 only_to_avoid_leaks = av_pop(stack);
15459                 SvREFCNT_dec(only_to_avoid_leaks);
15460                 av_push(stack, rhs);
15461                 goto redo_curchar;
15462
15463             case '!':   /* Highest priority, right associative */
15464
15465                 /* If what's already at the top of the stack is another '!",
15466                  * they just cancel each other out */
15467                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15468                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15469                 {
15470                     only_to_avoid_leaks = av_pop(stack);
15471                     SvREFCNT_dec(only_to_avoid_leaks);
15472                 }
15473                 else { /* Otherwise, since it's right associative, just push
15474                           onto the stack */
15475                     av_push(stack, newSVuv(curchar));
15476                 }
15477                 break;
15478
15479             default:
15480                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15481                 vFAIL("Unexpected character");
15482
15483           handle_operand:
15484
15485             /* Here 'current' is the operand.  If something is already on the
15486              * stack, we have to check if it is a !.  But first, the code above
15487              * may have altered the stack in the time since we earlier set
15488              * 'top_index'.  */
15489
15490             top_index = av_tindex_skip_len_mg(stack);
15491             if (top_index - fence >= 0) {
15492                 /* If the top entry on the stack is an operator, it had better
15493                  * be a '!', otherwise the entry below the top operand should
15494                  * be an operator */
15495                 top_ptr = av_fetch(stack, top_index, FALSE);
15496                 assert(top_ptr);
15497                 if (IS_OPERATOR(*top_ptr)) {
15498
15499                     /* The only permissible operator at the top of the stack is
15500                      * '!', which is applied immediately to this operand. */
15501                     curchar = (char) SvUV(*top_ptr);
15502                     if (curchar != '!') {
15503                         SvREFCNT_dec(current);
15504                         vFAIL2("Unexpected binary operator '%c' with no "
15505                                 "preceding operand", curchar);
15506                     }
15507
15508                     _invlist_invert(current);
15509
15510                     only_to_avoid_leaks = av_pop(stack);
15511                     SvREFCNT_dec(only_to_avoid_leaks);
15512
15513                     /* And we redo with the inverted operand.  This allows
15514                      * handling multiple ! in a row */
15515                     goto handle_operand;
15516                 }
15517                           /* Single operand is ok only for the non-binary ')'
15518                            * operator */
15519                 else if ((top_index - fence == 0 && curchar != ')')
15520                          || (top_index - fence > 0
15521                              && (! (stacked_ptr = av_fetch(stack,
15522                                                            top_index - 1,
15523                                                            FALSE))
15524                                  || IS_OPERAND(*stacked_ptr))))
15525                 {
15526                     SvREFCNT_dec(current);
15527                     vFAIL("Operand with no preceding operator");
15528                 }
15529             }
15530
15531             /* Here there was nothing on the stack or the top element was
15532              * another operand.  Just add this new one */
15533             av_push(stack, current);
15534
15535         } /* End of switch on next parse token */
15536
15537         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15538     } /* End of loop parsing through the construct */
15539
15540   done:
15541     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
15542         vFAIL("Unmatched (");
15543     }
15544
15545     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
15546         || ((final = av_pop(stack)) == NULL)
15547         || ! IS_OPERAND(final)
15548         || SvTYPE(final) != SVt_INVLIST
15549         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
15550     {
15551       bad_syntax:
15552         SvREFCNT_dec(final);
15553         vFAIL("Incomplete expression within '(?[ ])'");
15554     }
15555
15556     /* Here, 'final' is the resultant inversion list from evaluating the
15557      * expression.  Return it if so requested */
15558     if (return_invlist) {
15559         *return_invlist = final;
15560         return END;
15561     }
15562
15563     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15564      * expecting a string of ranges and individual code points */
15565     invlist_iterinit(final);
15566     result_string = newSVpvs("");
15567     while (invlist_iternext(final, &start, &end)) {
15568         if (start == end) {
15569             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
15570         }
15571         else {
15572             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
15573                                                      start,          end);
15574         }
15575     }
15576
15577     /* About to generate an ANYOF (or similar) node from the inversion list we
15578      * have calculated */
15579     save_parse = RExC_parse;
15580     RExC_parse = SvPV(result_string, len);
15581     save_end = RExC_end;
15582     RExC_end = RExC_parse + len;
15583
15584     /* We turn off folding around the call, as the class we have constructed
15585      * already has all folding taken into consideration, and we don't want
15586      * regclass() to add to that */
15587     RExC_flags &= ~RXf_PMf_FOLD;
15588     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15589      * folds are allowed.  */
15590     node = regclass(pRExC_state, flagp,depth+1,
15591                     FALSE, /* means parse the whole char class */
15592                     FALSE, /* don't allow multi-char folds */
15593                     TRUE, /* silence non-portable warnings.  The above may very
15594                              well have generated non-portable code points, but
15595                              they're valid on this machine */
15596                     FALSE, /* similarly, no need for strict */
15597                     FALSE, /* Require return to be an ANYOF */
15598                     NULL,
15599                     NULL
15600                 );
15601     if (!node)
15602         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#" UVxf,
15603                     PTR2UV(flagp));
15604
15605     /* Fix up the node type if we are in locale.  (We have pretended we are
15606      * under /u for the purposes of regclass(), as this construct will only
15607      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15608      * as to cause any warnings about bad locales to be output in regexec.c),
15609      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15610      * reason we above forbid optimization into something other than an ANYOF
15611      * node is simply to minimize the number of code changes in regexec.c.
15612      * Otherwise we would have to create new EXACTish node types and deal with
15613      * them.  This decision could be revisited should this construct become
15614      * popular.
15615      *
15616      * (One might think we could look at the resulting ANYOF node and suppress
15617      * the flag if everything is above 255, as those would be UTF-8 only,
15618      * but this isn't true, as the components that led to that result could
15619      * have been locale-affected, and just happen to cancel each other out
15620      * under UTF-8 locales.) */
15621     if (in_locale) {
15622         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15623
15624         assert(OP(node) == ANYOF);
15625
15626         OP(node) = ANYOFL;
15627         ANYOF_FLAGS(node)
15628                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
15629     }
15630
15631     if (save_fold) {
15632         RExC_flags |= RXf_PMf_FOLD;
15633     }
15634
15635     RExC_parse = save_parse + 1;
15636     RExC_end = save_end;
15637     SvREFCNT_dec_NN(final);
15638     SvREFCNT_dec_NN(result_string);
15639
15640     nextchar(pRExC_state);
15641     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
15642     return node;
15643 }
15644
15645 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15646
15647 STATIC void
15648 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
15649                              AV * stack, const IV fence, AV * fence_stack)
15650 {   /* Dumps the stacks in handle_regex_sets() */
15651
15652     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
15653     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
15654     SSize_t i;
15655
15656     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
15657
15658     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
15659
15660     if (stack_top < 0) {
15661         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
15662     }
15663     else {
15664         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
15665         for (i = stack_top; i >= 0; i--) {
15666             SV ** element_ptr = av_fetch(stack, i, FALSE);
15667             if (! element_ptr) {
15668             }
15669
15670             if (IS_OPERATOR(*element_ptr)) {
15671                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
15672                                             (int) i, (int) SvIV(*element_ptr));
15673             }
15674             else {
15675                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
15676                 sv_dump(*element_ptr);
15677             }
15678         }
15679     }
15680
15681     if (fence_stack_top < 0) {
15682         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
15683     }
15684     else {
15685         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
15686         for (i = fence_stack_top; i >= 0; i--) {
15687             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
15688             if (! element_ptr) {
15689             }
15690
15691             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
15692                                             (int) i, (int) SvIV(*element_ptr));
15693         }
15694     }
15695 }
15696
15697 #endif
15698
15699 #undef IS_OPERATOR
15700 #undef IS_OPERAND
15701
15702 STATIC void
15703 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
15704 {
15705     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
15706      * innocent-looking character class, like /[ks]/i won't have to go out to
15707      * disk to find the possible matches.
15708      *
15709      * This should be called only for a Latin1-range code points, cp, which is
15710      * known to be involved in a simple fold with other code points above
15711      * Latin1.  It would give false results if /aa has been specified.
15712      * Multi-char folds are outside the scope of this, and must be handled
15713      * specially.
15714      *
15715      * XXX It would be better to generate these via regen, in case a new
15716      * version of the Unicode standard adds new mappings, though that is not
15717      * really likely, and may be caught by the default: case of the switch
15718      * below. */
15719
15720     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
15721
15722     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
15723
15724     switch (cp) {
15725         case 'k':
15726         case 'K':
15727           *invlist =
15728              add_cp_to_invlist(*invlist, KELVIN_SIGN);
15729             break;
15730         case 's':
15731         case 'S':
15732           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
15733             break;
15734         case MICRO_SIGN:
15735           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
15736           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
15737             break;
15738         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
15739         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
15740           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
15741             break;
15742         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
15743           *invlist = add_cp_to_invlist(*invlist,
15744                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
15745             break;
15746
15747 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
15748
15749         case LATIN_SMALL_LETTER_SHARP_S:
15750           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
15751             break;
15752
15753 #endif
15754
15755 #if    UNICODE_MAJOR_VERSION < 3                                        \
15756    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
15757
15758         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
15759          * U+0131.  */
15760         case 'i':
15761         case 'I':
15762           *invlist =
15763              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
15764 #   if UNICODE_DOT_DOT_VERSION == 1
15765           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
15766 #   endif
15767             break;
15768 #endif
15769
15770         default:
15771             /* Use deprecated warning to increase the chances of this being
15772              * output */
15773             if (PASS2) {
15774                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
15775             }
15776             break;
15777     }
15778 }
15779
15780 STATIC void
15781 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
15782 {
15783     /* If the final parameter is NULL, output the elements of the array given
15784      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
15785      * pushed onto it, (creating if necessary) */
15786
15787     SV * msg;
15788     const bool first_is_fatal =  ! return_posix_warnings
15789                                 && ckDEAD(packWARN(WARN_REGEXP));
15790
15791     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
15792
15793     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
15794         if (return_posix_warnings) {
15795             if (! *return_posix_warnings) { /* mortalize to not leak if
15796                                                warnings are fatal */
15797                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
15798             }
15799             av_push(*return_posix_warnings, msg);
15800         }
15801         else {
15802             if (first_is_fatal) {           /* Avoid leaking this */
15803                 av_undef(posix_warnings);   /* This isn't necessary if the
15804                                                array is mortal, but is a
15805                                                fail-safe */
15806                 (void) sv_2mortal(msg);
15807                 if (PASS2) {
15808                     SAVEFREESV(RExC_rx_sv);
15809                 }
15810             }
15811             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
15812             SvREFCNT_dec_NN(msg);
15813         }
15814     }
15815 }
15816
15817 STATIC AV *
15818 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
15819 {
15820     /* This adds the string scalar <multi_string> to the array
15821      * <multi_char_matches>.  <multi_string> is known to have exactly
15822      * <cp_count> code points in it.  This is used when constructing a
15823      * bracketed character class and we find something that needs to match more
15824      * than a single character.
15825      *
15826      * <multi_char_matches> is actually an array of arrays.  Each top-level
15827      * element is an array that contains all the strings known so far that are
15828      * the same length.  And that length (in number of code points) is the same
15829      * as the index of the top-level array.  Hence, the [2] element is an
15830      * array, each element thereof is a string containing TWO code points;
15831      * while element [3] is for strings of THREE characters, and so on.  Since
15832      * this is for multi-char strings there can never be a [0] nor [1] element.
15833      *
15834      * When we rewrite the character class below, we will do so such that the
15835      * longest strings are written first, so that it prefers the longest
15836      * matching strings first.  This is done even if it turns out that any
15837      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
15838      * Christiansen has agreed that this is ok.  This makes the test for the
15839      * ligature 'ffi' come before the test for 'ff', for example */
15840
15841     AV* this_array;
15842     AV** this_array_ptr;
15843
15844     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
15845
15846     if (! multi_char_matches) {
15847         multi_char_matches = newAV();
15848     }
15849
15850     if (av_exists(multi_char_matches, cp_count)) {
15851         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
15852         this_array = *this_array_ptr;
15853     }
15854     else {
15855         this_array = newAV();
15856         av_store(multi_char_matches, cp_count,
15857                  (SV*) this_array);
15858     }
15859     av_push(this_array, multi_string);
15860
15861     return multi_char_matches;
15862 }
15863
15864 /* The names of properties whose definitions are not known at compile time are
15865  * stored in this SV, after a constant heading.  So if the length has been
15866  * changed since initialization, then there is a run-time definition. */
15867 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
15868                                         (SvCUR(listsv) != initial_listsv_len)
15869
15870 /* There is a restricted set of white space characters that are legal when
15871  * ignoring white space in a bracketed character class.  This generates the
15872  * code to skip them.
15873  *
15874  * There is a line below that uses the same white space criteria but is outside
15875  * this macro.  Both here and there must use the same definition */
15876 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
15877     STMT_START {                                                        \
15878         if (do_skip) {                                                  \
15879             while (isBLANK_A(UCHARAT(p)))                               \
15880             {                                                           \
15881                 p++;                                                    \
15882             }                                                           \
15883         }                                                               \
15884     } STMT_END
15885
15886 STATIC regnode *
15887 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
15888                  const bool stop_at_1,  /* Just parse the next thing, don't
15889                                            look for a full character class */
15890                  bool allow_multi_folds,
15891                  const bool silence_non_portable,   /* Don't output warnings
15892                                                        about too large
15893                                                        characters */
15894                  const bool strict,
15895                  bool optimizable,                  /* ? Allow a non-ANYOF return
15896                                                        node */
15897                  SV** ret_invlist, /* Return an inversion list, not a node */
15898                  AV** return_posix_warnings
15899           )
15900 {
15901     /* parse a bracketed class specification.  Most of these will produce an
15902      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
15903      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
15904      * under /i with multi-character folds: it will be rewritten following the
15905      * paradigm of this example, where the <multi-fold>s are characters which
15906      * fold to multiple character sequences:
15907      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
15908      * gets effectively rewritten as:
15909      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
15910      * reg() gets called (recursively) on the rewritten version, and this
15911      * function will return what it constructs.  (Actually the <multi-fold>s
15912      * aren't physically removed from the [abcdefghi], it's just that they are
15913      * ignored in the recursion by means of a flag:
15914      * <RExC_in_multi_char_class>.)
15915      *
15916      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
15917      * characters, with the corresponding bit set if that character is in the
15918      * list.  For characters above this, a range list or swash is used.  There
15919      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
15920      * determinable at compile time
15921      *
15922      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
15923      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
15924      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
15925      */
15926
15927     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
15928     IV range = 0;
15929     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
15930     regnode *ret;
15931     STRLEN numlen;
15932     int namedclass = OOB_NAMEDCLASS;
15933     char *rangebegin = NULL;
15934     bool need_class = 0;
15935     SV *listsv = NULL;
15936     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
15937                                       than just initialized.  */
15938     SV* properties = NULL;    /* Code points that match \p{} \P{} */
15939     SV* posixes = NULL;     /* Code points that match classes like [:word:],
15940                                extended beyond the Latin1 range.  These have to
15941                                be kept separate from other code points for much
15942                                of this function because their handling  is
15943                                different under /i, and for most classes under
15944                                /d as well */
15945     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
15946                                separate for a while from the non-complemented
15947                                versions because of complications with /d
15948                                matching */
15949     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
15950                                   treated more simply than the general case,
15951                                   leading to less compilation and execution
15952                                   work */
15953     UV element_count = 0;   /* Number of distinct elements in the class.
15954                                Optimizations may be possible if this is tiny */
15955     AV * multi_char_matches = NULL; /* Code points that fold to more than one
15956                                        character; used under /i */
15957     UV n;
15958     char * stop_ptr = RExC_end;    /* where to stop parsing */
15959
15960     /* ignore unescaped whitespace? */
15961     const bool skip_white = cBOOL(   ret_invlist
15962                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
15963
15964     /* Unicode properties are stored in a swash; this holds the current one
15965      * being parsed.  If this swash is the only above-latin1 component of the
15966      * character class, an optimization is to pass it directly on to the
15967      * execution engine.  Otherwise, it is set to NULL to indicate that there
15968      * are other things in the class that have to be dealt with at execution
15969      * time */
15970     SV* swash = NULL;           /* Code points that match \p{} \P{} */
15971
15972     /* Set if a component of this character class is user-defined; just passed
15973      * on to the engine */
15974     bool has_user_defined_property = FALSE;
15975
15976     /* inversion list of code points this node matches only when the target
15977      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
15978      * /d) */
15979     SV* has_upper_latin1_only_utf8_matches = NULL;
15980
15981     /* Inversion list of code points this node matches regardless of things
15982      * like locale, folding, utf8ness of the target string */
15983     SV* cp_list = NULL;
15984
15985     /* Like cp_list, but code points on this list need to be checked for things
15986      * that fold to/from them under /i */
15987     SV* cp_foldable_list = NULL;
15988
15989     /* Like cp_list, but code points on this list are valid only when the
15990      * runtime locale is UTF-8 */
15991     SV* only_utf8_locale_list = NULL;
15992
15993     /* In a range, if one of the endpoints is non-character-set portable,
15994      * meaning that it hard-codes a code point that may mean a different
15995      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
15996      * mnemonic '\t' which each mean the same character no matter which
15997      * character set the platform is on. */
15998     unsigned int non_portable_endpoint = 0;
15999
16000     /* Is the range unicode? which means on a platform that isn't 1-1 native
16001      * to Unicode (i.e. non-ASCII), each code point in it should be considered
16002      * to be a Unicode value.  */
16003     bool unicode_range = FALSE;
16004     bool invert = FALSE;    /* Is this class to be complemented */
16005
16006     bool warn_super = ALWAYS_WARN_SUPER;
16007
16008     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
16009         case we need to change the emitted regop to an EXACT. */
16010     const char * orig_parse = RExC_parse;
16011     const SSize_t orig_size = RExC_size;
16012     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
16013
16014     /* This variable is used to mark where the end in the input is of something
16015      * that looks like a POSIX construct but isn't.  During the parse, when
16016      * something looks like it could be such a construct is encountered, it is
16017      * checked for being one, but not if we've already checked this area of the
16018      * input.  Only after this position is reached do we check again */
16019     char *not_posix_region_end = RExC_parse - 1;
16020
16021     AV* posix_warnings = NULL;
16022     const bool do_posix_warnings =     return_posix_warnings
16023                                    || (PASS2 && ckWARN(WARN_REGEXP));
16024
16025     GET_RE_DEBUG_FLAGS_DECL;
16026
16027     PERL_ARGS_ASSERT_REGCLASS;
16028 #ifndef DEBUGGING
16029     PERL_UNUSED_ARG(depth);
16030 #endif
16031
16032     DEBUG_PARSE("clas");
16033
16034 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
16035     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
16036                                    && UNICODE_DOT_DOT_VERSION == 0)
16037     allow_multi_folds = FALSE;
16038 #endif
16039
16040     /* Assume we are going to generate an ANYOF node. */
16041     ret = reganode(pRExC_state,
16042                    (LOC)
16043                     ? ANYOFL
16044                     : ANYOF,
16045                    0);
16046
16047     if (SIZE_ONLY) {
16048         RExC_size += ANYOF_SKIP;
16049         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
16050     }
16051     else {
16052         ANYOF_FLAGS(ret) = 0;
16053
16054         RExC_emit += ANYOF_SKIP;
16055         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
16056         initial_listsv_len = SvCUR(listsv);
16057         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
16058     }
16059
16060     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16061
16062     assert(RExC_parse <= RExC_end);
16063
16064     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
16065         RExC_parse++;
16066         invert = TRUE;
16067         allow_multi_folds = FALSE;
16068         MARK_NAUGHTY(1);
16069         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16070     }
16071
16072     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
16073     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
16074         int maybe_class = handle_possible_posix(pRExC_state,
16075                                                 RExC_parse,
16076                                                 &not_posix_region_end,
16077                                                 NULL,
16078                                                 TRUE /* checking only */);
16079         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
16080             SAVEFREESV(RExC_rx_sv);
16081             ckWARN4reg(not_posix_region_end,
16082                     "POSIX syntax [%c %c] belongs inside character classes%s",
16083                     *RExC_parse, *RExC_parse,
16084                     (maybe_class == OOB_NAMEDCLASS)
16085                     ? ((POSIXCC_NOTYET(*RExC_parse))
16086                         ? " (but this one isn't implemented)"
16087                         : " (but this one isn't fully valid)")
16088                     : ""
16089                     );
16090             (void)ReREFCNT_inc(RExC_rx_sv);
16091         }
16092     }
16093
16094     /* If the caller wants us to just parse a single element, accomplish this
16095      * by faking the loop ending condition */
16096     if (stop_at_1 && RExC_end > RExC_parse) {
16097         stop_ptr = RExC_parse + 1;
16098     }
16099
16100     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
16101     if (UCHARAT(RExC_parse) == ']')
16102         goto charclassloop;
16103
16104     while (1) {
16105
16106         if (   posix_warnings
16107             && av_tindex_skip_len_mg(posix_warnings) >= 0
16108             && RExC_parse > not_posix_region_end)
16109         {
16110             /* Warnings about posix class issues are considered tentative until
16111              * we are far enough along in the parse that we can no longer
16112              * change our mind, at which point we either output them or add
16113              * them, if it has so specified, to what gets returned to the
16114              * caller.  This is done each time through the loop so that a later
16115              * class won't zap them before they have been dealt with. */
16116             output_or_return_posix_warnings(pRExC_state, posix_warnings,
16117                                             return_posix_warnings);
16118         }
16119
16120         if  (RExC_parse >= stop_ptr) {
16121             break;
16122         }
16123
16124         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16125
16126         if  (UCHARAT(RExC_parse) == ']') {
16127             break;
16128         }
16129
16130       charclassloop:
16131
16132         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
16133         save_value = value;
16134         save_prevvalue = prevvalue;
16135
16136         if (!range) {
16137             rangebegin = RExC_parse;
16138             element_count++;
16139             non_portable_endpoint = 0;
16140         }
16141         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
16142             value = utf8n_to_uvchr((U8*)RExC_parse,
16143                                    RExC_end - RExC_parse,
16144                                    &numlen, UTF8_ALLOW_DEFAULT);
16145             RExC_parse += numlen;
16146         }
16147         else
16148             value = UCHARAT(RExC_parse++);
16149
16150         if (value == '[') {
16151             char * posix_class_end;
16152             namedclass = handle_possible_posix(pRExC_state,
16153                                                RExC_parse,
16154                                                &posix_class_end,
16155                                                do_posix_warnings ? &posix_warnings : NULL,
16156                                                FALSE    /* die if error */);
16157             if (namedclass > OOB_NAMEDCLASS) {
16158
16159                 /* If there was an earlier attempt to parse this particular
16160                  * posix class, and it failed, it was a false alarm, as this
16161                  * successful one proves */
16162                 if (   posix_warnings
16163                     && av_tindex_skip_len_mg(posix_warnings) >= 0
16164                     && not_posix_region_end >= RExC_parse
16165                     && not_posix_region_end <= posix_class_end)
16166                 {
16167                     av_undef(posix_warnings);
16168                 }
16169
16170                 RExC_parse = posix_class_end;
16171             }
16172             else if (namedclass == OOB_NAMEDCLASS) {
16173                 not_posix_region_end = posix_class_end;
16174             }
16175             else {
16176                 namedclass = OOB_NAMEDCLASS;
16177             }
16178         }
16179         else if (   RExC_parse - 1 > not_posix_region_end
16180                  && MAYBE_POSIXCC(value))
16181         {
16182             (void) handle_possible_posix(
16183                         pRExC_state,
16184                         RExC_parse - 1,  /* -1 because parse has already been
16185                                             advanced */
16186                         &not_posix_region_end,
16187                         do_posix_warnings ? &posix_warnings : NULL,
16188                         TRUE /* checking only */);
16189         }
16190         else if (value == '\\') {
16191             /* Is a backslash; get the code point of the char after it */
16192
16193             if (RExC_parse >= RExC_end) {
16194                 vFAIL("Unmatched [");
16195             }
16196
16197             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16198                 value = utf8n_to_uvchr((U8*)RExC_parse,
16199                                    RExC_end - RExC_parse,
16200                                    &numlen, UTF8_ALLOW_DEFAULT);
16201                 RExC_parse += numlen;
16202             }
16203             else
16204                 value = UCHARAT(RExC_parse++);
16205
16206             /* Some compilers cannot handle switching on 64-bit integer
16207              * values, therefore value cannot be an UV.  Yes, this will
16208              * be a problem later if we want switch on Unicode.
16209              * A similar issue a little bit later when switching on
16210              * namedclass. --jhi */
16211
16212             /* If the \ is escaping white space when white space is being
16213              * skipped, it means that that white space is wanted literally, and
16214              * is already in 'value'.  Otherwise, need to translate the escape
16215              * into what it signifies. */
16216             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16217
16218             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16219             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16220             case 's':   namedclass = ANYOF_SPACE;       break;
16221             case 'S':   namedclass = ANYOF_NSPACE;      break;
16222             case 'd':   namedclass = ANYOF_DIGIT;       break;
16223             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16224             case 'v':   namedclass = ANYOF_VERTWS;      break;
16225             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16226             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16227             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16228             case 'N':  /* Handle \N{NAME} in class */
16229                 {
16230                     const char * const backslash_N_beg = RExC_parse - 2;
16231                     int cp_count;
16232
16233                     if (! grok_bslash_N(pRExC_state,
16234                                         NULL,      /* No regnode */
16235                                         &value,    /* Yes single value */
16236                                         &cp_count, /* Multiple code pt count */
16237                                         flagp,
16238                                         strict,
16239                                         depth)
16240                     ) {
16241
16242                         if (*flagp & NEED_UTF8)
16243                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16244                         if (*flagp & RESTART_PASS1)
16245                             return NULL;
16246
16247                         if (cp_count < 0) {
16248                             vFAIL("\\N in a character class must be a named character: \\N{...}");
16249                         }
16250                         else if (cp_count == 0) {
16251                             if (PASS2) {
16252                                 ckWARNreg(RExC_parse,
16253                                         "Ignoring zero length \\N{} in character class");
16254                             }
16255                         }
16256                         else { /* cp_count > 1 */
16257                             if (! RExC_in_multi_char_class) {
16258                                 if (invert || range || *RExC_parse == '-') {
16259                                     if (strict) {
16260                                         RExC_parse--;
16261                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
16262                                     }
16263                                     else if (PASS2) {
16264                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
16265                                     }
16266                                     break; /* <value> contains the first code
16267                                               point. Drop out of the switch to
16268                                               process it */
16269                                 }
16270                                 else {
16271                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
16272                                                  RExC_parse - backslash_N_beg);
16273                                     multi_char_matches
16274                                         = add_multi_match(multi_char_matches,
16275                                                           multi_char_N,
16276                                                           cp_count);
16277                                 }
16278                             }
16279                         } /* End of cp_count != 1 */
16280
16281                         /* This element should not be processed further in this
16282                          * class */
16283                         element_count--;
16284                         value = save_value;
16285                         prevvalue = save_prevvalue;
16286                         continue;   /* Back to top of loop to get next char */
16287                     }
16288
16289                     /* Here, is a single code point, and <value> contains it */
16290                     unicode_range = TRUE;   /* \N{} are Unicode */
16291                 }
16292                 break;
16293             case 'p':
16294             case 'P':
16295                 {
16296                 char *e;
16297
16298                 /* We will handle any undefined properties ourselves */
16299                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
16300                                        /* And we actually would prefer to get
16301                                         * the straight inversion list of the
16302                                         * swash, since we will be accessing it
16303                                         * anyway, to save a little time */
16304                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
16305
16306                 if (RExC_parse >= RExC_end)
16307                     vFAIL2("Empty \\%c", (U8)value);
16308                 if (*RExC_parse == '{') {
16309                     const U8 c = (U8)value;
16310                     e = strchr(RExC_parse, '}');
16311                     if (!e) {
16312                         RExC_parse++;
16313                         vFAIL2("Missing right brace on \\%c{}", c);
16314                     }
16315
16316                     RExC_parse++;
16317                     while (isSPACE(*RExC_parse)) {
16318                          RExC_parse++;
16319                     }
16320
16321                     if (UCHARAT(RExC_parse) == '^') {
16322
16323                         /* toggle.  (The rhs xor gets the single bit that
16324                          * differs between P and p; the other xor inverts just
16325                          * that bit) */
16326                         value ^= 'P' ^ 'p';
16327
16328                         RExC_parse++;
16329                         while (isSPACE(*RExC_parse)) {
16330                             RExC_parse++;
16331                         }
16332                     }
16333
16334                     if (e == RExC_parse)
16335                         vFAIL2("Empty \\%c{}", c);
16336
16337                     n = e - RExC_parse;
16338                     while (isSPACE(*(RExC_parse + n - 1)))
16339                         n--;
16340                 }   /* The \p isn't immediately followed by a '{' */
16341                 else if (! isALPHA(*RExC_parse)) {
16342                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16343                     vFAIL2("Character following \\%c must be '{' or a "
16344                            "single-character Unicode property name",
16345                            (U8) value);
16346                 }
16347                 else {
16348                     e = RExC_parse;
16349                     n = 1;
16350                 }
16351                 if (!SIZE_ONLY) {
16352                     SV* invlist;
16353                     char* name;
16354                     char* base_name;    /* name after any packages are stripped */
16355                     char* lookup_name = NULL;
16356                     const char * const colon_colon = "::";
16357
16358                     /* Try to get the definition of the property into
16359                      * <invlist>.  If /i is in effect, the effective property
16360                      * will have its name be <__NAME_i>.  The design is
16361                      * discussed in commit
16362                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
16363                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
16364                     SAVEFREEPV(name);
16365                     if (FOLD) {
16366                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
16367
16368                         /* The function call just below that uses this can fail
16369                          * to return, leaking memory if we don't do this */
16370                         SAVEFREEPV(lookup_name);
16371                     }
16372
16373                     /* Look up the property name, and get its swash and
16374                      * inversion list, if the property is found  */
16375                     SvREFCNT_dec(swash); /* Free any left-overs */
16376                     swash = _core_swash_init("utf8",
16377                                              (lookup_name)
16378                                               ? lookup_name
16379                                               : name,
16380                                              &PL_sv_undef,
16381                                              1, /* binary */
16382                                              0, /* not tr/// */
16383                                              NULL, /* No inversion list */
16384                                              &swash_init_flags
16385                                             );
16386                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
16387                         HV* curpkg = (IN_PERL_COMPILETIME)
16388                                       ? PL_curstash
16389                                       : CopSTASH(PL_curcop);
16390                         UV final_n = n;
16391                         bool has_pkg;
16392
16393                         if (swash) {    /* Got a swash but no inversion list.
16394                                            Something is likely wrong that will
16395                                            be sorted-out later */
16396                             SvREFCNT_dec_NN(swash);
16397                             swash = NULL;
16398                         }
16399
16400                         /* Here didn't find it.  It could be a an error (like a
16401                          * typo) in specifying a Unicode property, or it could
16402                          * be a user-defined property that will be available at
16403                          * run-time.  The names of these must begin with 'In'
16404                          * or 'Is' (after any packages are stripped off).  So
16405                          * if not one of those, or if we accept only
16406                          * compile-time properties, is an error; otherwise add
16407                          * it to the list for run-time look up. */
16408                         if ((base_name = rninstr(name, name + n,
16409                                                  colon_colon, colon_colon + 2)))
16410                         { /* Has ::.  We know this must be a user-defined
16411                              property */
16412                             base_name += 2;
16413                             final_n -= base_name - name;
16414                             has_pkg = TRUE;
16415                         }
16416                         else {
16417                             base_name = name;
16418                             has_pkg = FALSE;
16419                         }
16420
16421                         if (   final_n < 3
16422                             || base_name[0] != 'I'
16423                             || (base_name[1] != 's' && base_name[1] != 'n')
16424                             || ret_invlist)
16425                         {
16426                             const char * const msg
16427                                 = (has_pkg)
16428                                   ? "Illegal user-defined property name"
16429                                   : "Can't find Unicode property definition";
16430                             RExC_parse = e + 1;
16431
16432                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16433                             vFAIL3utf8f("%s \"%" UTF8f "\"",
16434                                 msg, UTF8fARG(UTF, n, name));
16435                         }
16436
16437                         /* If the property name doesn't already have a package
16438                          * name, add the current one to it so that it can be
16439                          * referred to outside it. [perl #121777] */
16440                         if (! has_pkg && curpkg) {
16441                             char* pkgname = HvNAME(curpkg);
16442                             if (strNE(pkgname, "main")) {
16443                                 char* full_name = Perl_form(aTHX_
16444                                                             "%s::%s",
16445                                                             pkgname,
16446                                                             name);
16447                                 n = strlen(full_name);
16448                                 name = savepvn(full_name, n);
16449                                 SAVEFREEPV(name);
16450                             }
16451                         }
16452                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
16453                                         (value == 'p' ? '+' : '!'),
16454                                         (FOLD) ? "__" : "",
16455                                         UTF8fARG(UTF, n, name),
16456                                         (FOLD) ? "_i" : "");
16457                         has_user_defined_property = TRUE;
16458                         optimizable = FALSE;    /* Will have to leave this an
16459                                                    ANYOF node */
16460
16461                         /* We don't know yet what this matches, so have to flag
16462                          * it */
16463                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16464                     }
16465                     else {
16466
16467                         /* Here, did get the swash and its inversion list.  If
16468                          * the swash is from a user-defined property, then this
16469                          * whole character class should be regarded as such */
16470                         if (swash_init_flags
16471                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16472                         {
16473                             has_user_defined_property = TRUE;
16474                         }
16475                         else if
16476                             /* We warn on matching an above-Unicode code point
16477                              * if the match would return true, except don't
16478                              * warn for \p{All}, which has exactly one element
16479                              * = 0 */
16480                             (_invlist_contains_cp(invlist, 0x110000)
16481                                 && (! (_invlist_len(invlist) == 1
16482                                        && *invlist_array(invlist) == 0)))
16483                         {
16484                             warn_super = TRUE;
16485                         }
16486
16487
16488                         /* Invert if asking for the complement */
16489                         if (value == 'P') {
16490                             _invlist_union_complement_2nd(properties,
16491                                                           invlist,
16492                                                           &properties);
16493
16494                             /* The swash can't be used as-is, because we've
16495                              * inverted things; delay removing it to here after
16496                              * have copied its invlist above */
16497                             SvREFCNT_dec_NN(swash);
16498                             swash = NULL;
16499                         }
16500                         else {
16501                             _invlist_union(properties, invlist, &properties);
16502                         }
16503                     }
16504                 }
16505                 RExC_parse = e + 1;
16506                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16507                                                 named */
16508
16509                 /* \p means they want Unicode semantics */
16510                 REQUIRE_UNI_RULES(flagp, NULL);
16511                 }
16512                 break;
16513             case 'n':   value = '\n';                   break;
16514             case 'r':   value = '\r';                   break;
16515             case 't':   value = '\t';                   break;
16516             case 'f':   value = '\f';                   break;
16517             case 'b':   value = '\b';                   break;
16518             case 'e':   value = ESC_NATIVE;             break;
16519             case 'a':   value = '\a';                   break;
16520             case 'o':
16521                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16522                 {
16523                     const char* error_msg;
16524                     bool valid = grok_bslash_o(&RExC_parse,
16525                                                &value,
16526                                                &error_msg,
16527                                                PASS2,   /* warnings only in
16528                                                            pass 2 */
16529                                                strict,
16530                                                silence_non_portable,
16531                                                UTF);
16532                     if (! valid) {
16533                         vFAIL(error_msg);
16534                     }
16535                 }
16536                 non_portable_endpoint++;
16537                 break;
16538             case 'x':
16539                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16540                 {
16541                     const char* error_msg;
16542                     bool valid = grok_bslash_x(&RExC_parse,
16543                                                &value,
16544                                                &error_msg,
16545                                                PASS2, /* Output warnings */
16546                                                strict,
16547                                                silence_non_portable,
16548                                                UTF);
16549                     if (! valid) {
16550                         vFAIL(error_msg);
16551                     }
16552                 }
16553                 non_portable_endpoint++;
16554                 break;
16555             case 'c':
16556                 value = grok_bslash_c(*RExC_parse++, PASS2);
16557                 non_portable_endpoint++;
16558                 break;
16559             case '0': case '1': case '2': case '3': case '4':
16560             case '5': case '6': case '7':
16561                 {
16562                     /* Take 1-3 octal digits */
16563                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16564                     numlen = (strict) ? 4 : 3;
16565                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16566                     RExC_parse += numlen;
16567                     if (numlen != 3) {
16568                         if (strict) {
16569                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16570                             vFAIL("Need exactly 3 octal digits");
16571                         }
16572                         else if (! SIZE_ONLY /* like \08, \178 */
16573                                  && numlen < 3
16574                                  && RExC_parse < RExC_end
16575                                  && isDIGIT(*RExC_parse)
16576                                  && ckWARN(WARN_REGEXP))
16577                         {
16578                             SAVEFREESV(RExC_rx_sv);
16579                             reg_warn_non_literal_string(
16580                                  RExC_parse + 1,
16581                                  form_short_octal_warning(RExC_parse, numlen));
16582                             (void)ReREFCNT_inc(RExC_rx_sv);
16583                         }
16584                     }
16585                     non_portable_endpoint++;
16586                     break;
16587                 }
16588             default:
16589                 /* Allow \_ to not give an error */
16590                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16591                     if (strict) {
16592                         vFAIL2("Unrecognized escape \\%c in character class",
16593                                (int)value);
16594                     }
16595                     else {
16596                         SAVEFREESV(RExC_rx_sv);
16597                         ckWARN2reg(RExC_parse,
16598                             "Unrecognized escape \\%c in character class passed through",
16599                             (int)value);
16600                         (void)ReREFCNT_inc(RExC_rx_sv);
16601                     }
16602                 }
16603                 break;
16604             }   /* End of switch on char following backslash */
16605         } /* end of handling backslash escape sequences */
16606
16607         /* Here, we have the current token in 'value' */
16608
16609         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
16610             U8 classnum;
16611
16612             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
16613              * literal, as is the character that began the false range, i.e.
16614              * the 'a' in the examples */
16615             if (range) {
16616                 if (!SIZE_ONLY) {
16617                     const int w = (RExC_parse >= rangebegin)
16618                                   ? RExC_parse - rangebegin
16619                                   : 0;
16620                     if (strict) {
16621                         vFAIL2utf8f(
16622                             "False [] range \"%" UTF8f "\"",
16623                             UTF8fARG(UTF, w, rangebegin));
16624                     }
16625                     else {
16626                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
16627                         ckWARN2reg(RExC_parse,
16628                             "False [] range \"%" UTF8f "\"",
16629                             UTF8fARG(UTF, w, rangebegin));
16630                         (void)ReREFCNT_inc(RExC_rx_sv);
16631                         cp_list = add_cp_to_invlist(cp_list, '-');
16632                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
16633                                                              prevvalue);
16634                     }
16635                 }
16636
16637                 range = 0; /* this was not a true range */
16638                 element_count += 2; /* So counts for three values */
16639             }
16640
16641             classnum = namedclass_to_classnum(namedclass);
16642
16643             if (LOC && namedclass < ANYOF_POSIXL_MAX
16644 #ifndef HAS_ISASCII
16645                 && classnum != _CC_ASCII
16646 #endif
16647             ) {
16648                 /* What the Posix classes (like \w, [:space:]) match in locale
16649                  * isn't knowable under locale until actual match time.  Room
16650                  * must be reserved (one time per outer bracketed class) to
16651                  * store such classes.  The space will contain a bit for each
16652                  * named class that is to be matched against.  This isn't
16653                  * needed for \p{} and pseudo-classes, as they are not affected
16654                  * by locale, and hence are dealt with separately */
16655                 if (! need_class) {
16656                     need_class = 1;
16657                     if (SIZE_ONLY) {
16658                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16659                     }
16660                     else {
16661                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16662                     }
16663                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
16664                     ANYOF_POSIXL_ZERO(ret);
16665
16666                     /* We can't change this into some other type of node
16667                      * (unless this is the only element, in which case there
16668                      * are nodes that mean exactly this) as has runtime
16669                      * dependencies */
16670                     optimizable = FALSE;
16671                 }
16672
16673                 /* Coverity thinks it is possible for this to be negative; both
16674                  * jhi and khw think it's not, but be safer */
16675                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16676                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
16677
16678                 /* See if it already matches the complement of this POSIX
16679                  * class */
16680                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16681                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
16682                                                             ? -1
16683                                                             : 1)))
16684                 {
16685                     posixl_matches_all = TRUE;
16686                     break;  /* No need to continue.  Since it matches both
16687                                e.g., \w and \W, it matches everything, and the
16688                                bracketed class can be optimized into qr/./s */
16689                 }
16690
16691                 /* Add this class to those that should be checked at runtime */
16692                 ANYOF_POSIXL_SET(ret, namedclass);
16693
16694                 /* The above-Latin1 characters are not subject to locale rules.
16695                  * Just add them, in the second pass, to the
16696                  * unconditionally-matched list */
16697                 if (! SIZE_ONLY) {
16698                     SV* scratch_list = NULL;
16699
16700                     /* Get the list of the above-Latin1 code points this
16701                      * matches */
16702                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
16703                                           PL_XPosix_ptrs[classnum],
16704
16705                                           /* Odd numbers are complements, like
16706                                            * NDIGIT, NASCII, ... */
16707                                           namedclass % 2 != 0,
16708                                           &scratch_list);
16709                     /* Checking if 'cp_list' is NULL first saves an extra
16710                      * clone.  Its reference count will be decremented at the
16711                      * next union, etc, or if this is the only instance, at the
16712                      * end of the routine */
16713                     if (! cp_list) {
16714                         cp_list = scratch_list;
16715                     }
16716                     else {
16717                         _invlist_union(cp_list, scratch_list, &cp_list);
16718                         SvREFCNT_dec_NN(scratch_list);
16719                     }
16720                     continue;   /* Go get next character */
16721                 }
16722             }
16723             else if (! SIZE_ONLY) {
16724
16725                 /* Here, not in pass1 (in that pass we skip calculating the
16726                  * contents of this class), and is not /l, or is a POSIX class
16727                  * for which /l doesn't matter (or is a Unicode property, which
16728                  * is skipped here). */
16729                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
16730                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
16731
16732                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
16733                          * nor /l make a difference in what these match,
16734                          * therefore we just add what they match to cp_list. */
16735                         if (classnum != _CC_VERTSPACE) {
16736                             assert(   namedclass == ANYOF_HORIZWS
16737                                    || namedclass == ANYOF_NHORIZWS);
16738
16739                             /* It turns out that \h is just a synonym for
16740                              * XPosixBlank */
16741                             classnum = _CC_BLANK;
16742                         }
16743
16744                         _invlist_union_maybe_complement_2nd(
16745                                 cp_list,
16746                                 PL_XPosix_ptrs[classnum],
16747                                 namedclass % 2 != 0,    /* Complement if odd
16748                                                           (NHORIZWS, NVERTWS)
16749                                                         */
16750                                 &cp_list);
16751                     }
16752                 }
16753                 else if (  UNI_SEMANTICS
16754                         || classnum == _CC_ASCII
16755                         || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
16756                                                   || classnum == _CC_XDIGIT)))
16757                 {
16758                     /* We usually have to worry about /d and /a affecting what
16759                      * POSIX classes match, with special code needed for /d
16760                      * because we won't know until runtime what all matches.
16761                      * But there is no extra work needed under /u, and
16762                      * [:ascii:] is unaffected by /a and /d; and :digit: and
16763                      * :xdigit: don't have runtime differences under /d.  So we
16764                      * can special case these, and avoid some extra work below,
16765                      * and at runtime. */
16766                     _invlist_union_maybe_complement_2nd(
16767                                                      simple_posixes,
16768                                                      PL_XPosix_ptrs[classnum],
16769                                                      namedclass % 2 != 0,
16770                                                      &simple_posixes);
16771                 }
16772                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
16773                            complement and use nposixes */
16774                     SV** posixes_ptr = namedclass % 2 == 0
16775                                        ? &posixes
16776                                        : &nposixes;
16777                     _invlist_union_maybe_complement_2nd(
16778                                                      *posixes_ptr,
16779                                                      PL_XPosix_ptrs[classnum],
16780                                                      namedclass % 2 != 0,
16781                                                      posixes_ptr);
16782                 }
16783             }
16784         } /* end of namedclass \blah */
16785
16786         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16787
16788         /* If 'range' is set, 'value' is the ending of a range--check its
16789          * validity.  (If value isn't a single code point in the case of a
16790          * range, we should have figured that out above in the code that
16791          * catches false ranges).  Later, we will handle each individual code
16792          * point in the range.  If 'range' isn't set, this could be the
16793          * beginning of a range, so check for that by looking ahead to see if
16794          * the next real character to be processed is the range indicator--the
16795          * minus sign */
16796
16797         if (range) {
16798 #ifdef EBCDIC
16799             /* For unicode ranges, we have to test that the Unicode as opposed
16800              * to the native values are not decreasing.  (Above 255, there is
16801              * no difference between native and Unicode) */
16802             if (unicode_range && prevvalue < 255 && value < 255) {
16803                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
16804                     goto backwards_range;
16805                 }
16806             }
16807             else
16808 #endif
16809             if (prevvalue > value) /* b-a */ {
16810                 int w;
16811 #ifdef EBCDIC
16812               backwards_range:
16813 #endif
16814                 w = RExC_parse - rangebegin;
16815                 vFAIL2utf8f(
16816                     "Invalid [] range \"%" UTF8f "\"",
16817                     UTF8fARG(UTF, w, rangebegin));
16818                 NOT_REACHED; /* NOTREACHED */
16819             }
16820         }
16821         else {
16822             prevvalue = value; /* save the beginning of the potential range */
16823             if (! stop_at_1     /* Can't be a range if parsing just one thing */
16824                 && *RExC_parse == '-')
16825             {
16826                 char* next_char_ptr = RExC_parse + 1;
16827
16828                 /* Get the next real char after the '-' */
16829                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
16830
16831                 /* If the '-' is at the end of the class (just before the ']',
16832                  * it is a literal minus; otherwise it is a range */
16833                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
16834                     RExC_parse = next_char_ptr;
16835
16836                     /* a bad range like \w-, [:word:]- ? */
16837                     if (namedclass > OOB_NAMEDCLASS) {
16838                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
16839                             const int w = RExC_parse >= rangebegin
16840                                           ?  RExC_parse - rangebegin
16841                                           : 0;
16842                             if (strict) {
16843                                 vFAIL4("False [] range \"%*.*s\"",
16844                                     w, w, rangebegin);
16845                             }
16846                             else if (PASS2) {
16847                                 vWARN4(RExC_parse,
16848                                     "False [] range \"%*.*s\"",
16849                                     w, w, rangebegin);
16850                             }
16851                         }
16852                         if (!SIZE_ONLY) {
16853                             cp_list = add_cp_to_invlist(cp_list, '-');
16854                         }
16855                         element_count++;
16856                     } else
16857                         range = 1;      /* yeah, it's a range! */
16858                     continue;   /* but do it the next time */
16859                 }
16860             }
16861         }
16862
16863         if (namedclass > OOB_NAMEDCLASS) {
16864             continue;
16865         }
16866
16867         /* Here, we have a single value this time through the loop, and
16868          * <prevvalue> is the beginning of the range, if any; or <value> if
16869          * not. */
16870
16871         /* non-Latin1 code point implies unicode semantics.  Must be set in
16872          * pass1 so is there for the whole of pass 2 */
16873         if (value > 255) {
16874             REQUIRE_UNI_RULES(flagp, NULL);
16875         }
16876
16877         /* Ready to process either the single value, or the completed range.
16878          * For single-valued non-inverted ranges, we consider the possibility
16879          * of multi-char folds.  (We made a conscious decision to not do this
16880          * for the other cases because it can often lead to non-intuitive
16881          * results.  For example, you have the peculiar case that:
16882          *  "s s" =~ /^[^\xDF]+$/i => Y
16883          *  "ss"  =~ /^[^\xDF]+$/i => N
16884          *
16885          * See [perl #89750] */
16886         if (FOLD && allow_multi_folds && value == prevvalue) {
16887             if (value == LATIN_SMALL_LETTER_SHARP_S
16888                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
16889                                                         value)))
16890             {
16891                 /* Here <value> is indeed a multi-char fold.  Get what it is */
16892
16893                 U8 foldbuf[UTF8_MAXBYTES_CASE];
16894                 STRLEN foldlen;
16895
16896                 UV folded = _to_uni_fold_flags(
16897                                 value,
16898                                 foldbuf,
16899                                 &foldlen,
16900                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
16901                                                    ? FOLD_FLAGS_NOMIX_ASCII
16902                                                    : 0)
16903                                 );
16904
16905                 /* Here, <folded> should be the first character of the
16906                  * multi-char fold of <value>, with <foldbuf> containing the
16907                  * whole thing.  But, if this fold is not allowed (because of
16908                  * the flags), <fold> will be the same as <value>, and should
16909                  * be processed like any other character, so skip the special
16910                  * handling */
16911                 if (folded != value) {
16912
16913                     /* Skip if we are recursed, currently parsing the class
16914                      * again.  Otherwise add this character to the list of
16915                      * multi-char folds. */
16916                     if (! RExC_in_multi_char_class) {
16917                         STRLEN cp_count = utf8_length(foldbuf,
16918                                                       foldbuf + foldlen);
16919                         SV* multi_fold = sv_2mortal(newSVpvs(""));
16920
16921                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
16922
16923                         multi_char_matches
16924                                         = add_multi_match(multi_char_matches,
16925                                                           multi_fold,
16926                                                           cp_count);
16927
16928                     }
16929
16930                     /* This element should not be processed further in this
16931                      * class */
16932                     element_count--;
16933                     value = save_value;
16934                     prevvalue = save_prevvalue;
16935                     continue;
16936                 }
16937             }
16938         }
16939
16940         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
16941             if (range) {
16942
16943                 /* If the range starts above 255, everything is portable and
16944                  * likely to be so for any forseeable character set, so don't
16945                  * warn. */
16946                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
16947                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
16948                 }
16949                 else if (prevvalue != value) {
16950
16951                     /* Under strict, ranges that stop and/or end in an ASCII
16952                      * printable should have each end point be a portable value
16953                      * for it (preferably like 'A', but we don't warn if it is
16954                      * a (portable) Unicode name or code point), and the range
16955                      * must be be all digits or all letters of the same case.
16956                      * Otherwise, the range is non-portable and unclear as to
16957                      * what it contains */
16958                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
16959                         && (          non_portable_endpoint
16960                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
16961                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
16962                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
16963                     ))) {
16964                         vWARN(RExC_parse, "Ranges of ASCII printables should"
16965                                           " be some subset of \"0-9\","
16966                                           " \"A-Z\", or \"a-z\"");
16967                     }
16968                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
16969                         SSize_t index_start;
16970                         SSize_t index_final;
16971
16972                         /* But the nature of Unicode and languages mean we
16973                          * can't do the same checks for above-ASCII ranges,
16974                          * except in the case of digit ones.  These should
16975                          * contain only digits from the same group of 10.  The
16976                          * ASCII case is handled just above.  0x660 is the
16977                          * first digit character beyond ASCII.  Hence here, the
16978                          * range could be a range of digits.  First some
16979                          * unlikely special cases.  Grandfather in that a range
16980                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
16981                          * if its starting value is one of the 10 digits prior
16982                          * to it.  This is because it is an alternate way of
16983                          * writing 19D1, and some people may expect it to be in
16984                          * that group.  But it is bad, because it won't give
16985                          * the expected results.  In Unicode 5.2 it was
16986                          * considered to be in that group (of 11, hence), but
16987                          * this was fixed in the next version */
16988
16989                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
16990                             goto warn_bad_digit_range;
16991                         }
16992                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
16993                                           &&     value <= 0x1D7FF))
16994                         {
16995                             /* This is the only other case currently in Unicode
16996                              * where the algorithm below fails.  The code
16997                              * points just above are the end points of a single
16998                              * range containing only decimal digits.  It is 5
16999                              * different series of 0-9.  All other ranges of
17000                              * digits currently in Unicode are just a single
17001                              * series.  (And mktables will notify us if a later
17002                              * Unicode version breaks this.)
17003                              *
17004                              * If the range being checked is at most 9 long,
17005                              * and the digit values represented are in
17006                              * numerical order, they are from the same series.
17007                              * */
17008                             if (         value - prevvalue > 9
17009                                 ||    (((    value - 0x1D7CE) % 10)
17010                                      <= (prevvalue - 0x1D7CE) % 10))
17011                             {
17012                                 goto warn_bad_digit_range;
17013                             }
17014                         }
17015                         else {
17016
17017                             /* For all other ranges of digits in Unicode, the
17018                              * algorithm is just to check if both end points
17019                              * are in the same series, which is the same range.
17020                              * */
17021                             index_start = _invlist_search(
17022                                                     PL_XPosix_ptrs[_CC_DIGIT],
17023                                                     prevvalue);
17024
17025                             /* Warn if the range starts and ends with a digit,
17026                              * and they are not in the same group of 10. */
17027                             if (   index_start >= 0
17028                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
17029                                 && (index_final =
17030                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
17031                                                     value)) != index_start
17032                                 && index_final >= 0
17033                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
17034                             {
17035                               warn_bad_digit_range:
17036                                 vWARN(RExC_parse, "Ranges of digits should be"
17037                                                   " from the same group of"
17038                                                   " 10");
17039                             }
17040                         }
17041                     }
17042                 }
17043             }
17044             if ((! range || prevvalue == value) && non_portable_endpoint) {
17045                 if (isPRINT_A(value)) {
17046                     char literal[3];
17047                     unsigned d = 0;
17048                     if (isBACKSLASHED_PUNCT(value)) {
17049                         literal[d++] = '\\';
17050                     }
17051                     literal[d++] = (char) value;
17052                     literal[d++] = '\0';
17053
17054                     vWARN4(RExC_parse,
17055                            "\"%.*s\" is more clearly written simply as \"%s\"",
17056                            (int) (RExC_parse - rangebegin),
17057                            rangebegin,
17058                            literal
17059                         );
17060                 }
17061                 else if isMNEMONIC_CNTRL(value) {
17062                     vWARN4(RExC_parse,
17063                            "\"%.*s\" is more clearly written simply as \"%s\"",
17064                            (int) (RExC_parse - rangebegin),
17065                            rangebegin,
17066                            cntrl_to_mnemonic((U8) value)
17067                         );
17068                 }
17069             }
17070         }
17071
17072         /* Deal with this element of the class */
17073         if (! SIZE_ONLY) {
17074
17075 #ifndef EBCDIC
17076             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17077                                                      prevvalue, value);
17078 #else
17079             /* On non-ASCII platforms, for ranges that span all of 0..255, and
17080              * ones that don't require special handling, we can just add the
17081              * range like we do for ASCII platforms */
17082             if ((UNLIKELY(prevvalue == 0) && value >= 255)
17083                 || ! (prevvalue < 256
17084                       && (unicode_range
17085                           || (! non_portable_endpoint
17086                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
17087                                   || (isUPPER_A(prevvalue)
17088                                       && isUPPER_A(value)))))))
17089             {
17090                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17091                                                          prevvalue, value);
17092             }
17093             else {
17094                 /* Here, requires special handling.  This can be because it is
17095                  * a range whose code points are considered to be Unicode, and
17096                  * so must be individually translated into native, or because
17097                  * its a subrange of 'A-Z' or 'a-z' which each aren't
17098                  * contiguous in EBCDIC, but we have defined them to include
17099                  * only the "expected" upper or lower case ASCII alphabetics.
17100                  * Subranges above 255 are the same in native and Unicode, so
17101                  * can be added as a range */
17102                 U8 start = NATIVE_TO_LATIN1(prevvalue);
17103                 unsigned j;
17104                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
17105                 for (j = start; j <= end; j++) {
17106                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
17107                 }
17108                 if (value > 255) {
17109                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17110                                                              256, value);
17111                 }
17112             }
17113 #endif
17114         }
17115
17116         range = 0; /* this range (if it was one) is done now */
17117     } /* End of loop through all the text within the brackets */
17118
17119
17120     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
17121         output_or_return_posix_warnings(pRExC_state, posix_warnings,
17122                                         return_posix_warnings);
17123     }
17124
17125     /* If anything in the class expands to more than one character, we have to
17126      * deal with them by building up a substitute parse string, and recursively
17127      * calling reg() on it, instead of proceeding */
17128     if (multi_char_matches) {
17129         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
17130         I32 cp_count;
17131         STRLEN len;
17132         char *save_end = RExC_end;
17133         char *save_parse = RExC_parse;
17134         char *save_start = RExC_start;
17135         STRLEN prefix_end = 0;      /* We copy the character class after a
17136                                        prefix supplied here.  This is the size
17137                                        + 1 of that prefix */
17138         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
17139                                        a "|" */
17140         I32 reg_flags;
17141
17142         assert(! invert);
17143         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
17144
17145 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
17146            because too confusing */
17147         if (invert) {
17148             sv_catpv(substitute_parse, "(?:");
17149         }
17150 #endif
17151
17152         /* Look at the longest folds first */
17153         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
17154                         cp_count > 0;
17155                         cp_count--)
17156         {
17157
17158             if (av_exists(multi_char_matches, cp_count)) {
17159                 AV** this_array_ptr;
17160                 SV* this_sequence;
17161
17162                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
17163                                                  cp_count, FALSE);
17164                 while ((this_sequence = av_pop(*this_array_ptr)) !=
17165                                                                 &PL_sv_undef)
17166                 {
17167                     if (! first_time) {
17168                         sv_catpv(substitute_parse, "|");
17169                     }
17170                     first_time = FALSE;
17171
17172                     sv_catpv(substitute_parse, SvPVX(this_sequence));
17173                 }
17174             }
17175         }
17176
17177         /* If the character class contains anything else besides these
17178          * multi-character folds, have to include it in recursive parsing */
17179         if (element_count) {
17180             sv_catpv(substitute_parse, "|[");
17181             prefix_end = SvCUR(substitute_parse);
17182             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17183
17184             /* Put in a closing ']' only if not going off the end, as otherwise
17185              * we are adding something that really isn't there */
17186             if (RExC_parse < RExC_end) {
17187                 sv_catpv(substitute_parse, "]");
17188             }
17189         }
17190
17191         sv_catpv(substitute_parse, ")");
17192 #if 0
17193         if (invert) {
17194             /* This is a way to get the parse to skip forward a whole named
17195              * sequence instead of matching the 2nd character when it fails the
17196              * first */
17197             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17198         }
17199 #endif
17200
17201         /* Set up the data structure so that any errors will be properly
17202          * reported.  See the comments at the definition of
17203          * REPORT_LOCATION_ARGS for details */
17204         RExC_precomp_adj = orig_parse - RExC_precomp;
17205         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
17206         RExC_adjusted_start = RExC_start + prefix_end;
17207         RExC_end = RExC_parse + len;
17208         RExC_in_multi_char_class = 1;
17209         RExC_emit = (regnode *)orig_emit;
17210
17211         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17212
17213         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
17214
17215         /* And restore so can parse the rest of the pattern */
17216         RExC_parse = save_parse;
17217         RExC_start = RExC_adjusted_start = save_start;
17218         RExC_precomp_adj = 0;
17219         RExC_end = save_end;
17220         RExC_in_multi_char_class = 0;
17221         SvREFCNT_dec_NN(multi_char_matches);
17222         return ret;
17223     }
17224
17225     /* Here, we've gone through the entire class and dealt with multi-char
17226      * folds.  We are now in a position that we can do some checks to see if we
17227      * can optimize this ANYOF node into a simpler one, even in Pass 1.
17228      * Currently we only do two checks:
17229      * 1) is in the unlikely event that the user has specified both, eg. \w and
17230      *    \W under /l, then the class matches everything.  (This optimization
17231      *    is done only to make the optimizer code run later work.)
17232      * 2) if the character class contains only a single element (including a
17233      *    single range), we see if there is an equivalent node for it.
17234      * Other checks are possible */
17235     if (   optimizable
17236         && ! ret_invlist   /* Can't optimize if returning the constructed
17237                               inversion list */
17238         && (UNLIKELY(posixl_matches_all) || element_count == 1))
17239     {
17240         U8 op = END;
17241         U8 arg = 0;
17242
17243         if (UNLIKELY(posixl_matches_all)) {
17244             op = SANY;
17245         }
17246         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
17247                                                    class, like \w or [:digit:]
17248                                                    or \p{foo} */
17249
17250             /* All named classes are mapped into POSIXish nodes, with its FLAG
17251              * argument giving which class it is */
17252             switch ((I32)namedclass) {
17253                 case ANYOF_UNIPROP:
17254                     break;
17255
17256                 /* These don't depend on the charset modifiers.  They always
17257                  * match under /u rules */
17258                 case ANYOF_NHORIZWS:
17259                 case ANYOF_HORIZWS:
17260                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
17261                     /* FALLTHROUGH */
17262
17263                 case ANYOF_NVERTWS:
17264                 case ANYOF_VERTWS:
17265                     op = POSIXU;
17266                     goto join_posix;
17267
17268                 /* The actual POSIXish node for all the rest depends on the
17269                  * charset modifier.  The ones in the first set depend only on
17270                  * ASCII or, if available on this platform, also locale */
17271                 case ANYOF_ASCII:
17272                 case ANYOF_NASCII:
17273 #ifdef HAS_ISASCII
17274                     op = (LOC) ? POSIXL : POSIXA;
17275 #else
17276                     op = POSIXA;
17277 #endif
17278                     goto join_posix;
17279
17280                 /* The following don't have any matches in the upper Latin1
17281                  * range, hence /d is equivalent to /u for them.  Making it /u
17282                  * saves some branches at runtime */
17283                 case ANYOF_DIGIT:
17284                 case ANYOF_NDIGIT:
17285                 case ANYOF_XDIGIT:
17286                 case ANYOF_NXDIGIT:
17287                     if (! DEPENDS_SEMANTICS) {
17288                         goto treat_as_default;
17289                     }
17290
17291                     op = POSIXU;
17292                     goto join_posix;
17293
17294                 /* The following change to CASED under /i */
17295                 case ANYOF_LOWER:
17296                 case ANYOF_NLOWER:
17297                 case ANYOF_UPPER:
17298                 case ANYOF_NUPPER:
17299                     if (FOLD) {
17300                         namedclass = ANYOF_CASED + (namedclass % 2);
17301                     }
17302                     /* FALLTHROUGH */
17303
17304                 /* The rest have more possibilities depending on the charset.
17305                  * We take advantage of the enum ordering of the charset
17306                  * modifiers to get the exact node type, */
17307                 default:
17308                   treat_as_default:
17309                     op = POSIXD + get_regex_charset(RExC_flags);
17310                     if (op > POSIXA) { /* /aa is same as /a */
17311                         op = POSIXA;
17312                     }
17313
17314                   join_posix:
17315                     /* The odd numbered ones are the complements of the
17316                      * next-lower even number one */
17317                     if (namedclass % 2 == 1) {
17318                         invert = ! invert;
17319                         namedclass--;
17320                     }
17321                     arg = namedclass_to_classnum(namedclass);
17322                     break;
17323             }
17324         }
17325         else if (value == prevvalue) {
17326
17327             /* Here, the class consists of just a single code point */
17328
17329             if (invert) {
17330                 if (! LOC && value == '\n') {
17331                     op = REG_ANY; /* Optimize [^\n] */
17332                     *flagp |= HASWIDTH|SIMPLE;
17333                     MARK_NAUGHTY(1);
17334                 }
17335             }
17336             else if (value < 256 || UTF) {
17337
17338                 /* Optimize a single value into an EXACTish node, but not if it
17339                  * would require converting the pattern to UTF-8. */
17340                 op = compute_EXACTish(pRExC_state);
17341             }
17342         } /* Otherwise is a range */
17343         else if (! LOC) {   /* locale could vary these */
17344             if (prevvalue == '0') {
17345                 if (value == '9') {
17346                     arg = _CC_DIGIT;
17347                     op = POSIXA;
17348                 }
17349             }
17350             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
17351                 /* We can optimize A-Z or a-z, but not if they could match
17352                  * something like the KELVIN SIGN under /i. */
17353                 if (prevvalue == 'A') {
17354                     if (value == 'Z'
17355 #ifdef EBCDIC
17356                         && ! non_portable_endpoint
17357 #endif
17358                     ) {
17359                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
17360                         op = POSIXA;
17361                     }
17362                 }
17363                 else if (prevvalue == 'a') {
17364                     if (value == 'z'
17365 #ifdef EBCDIC
17366                         && ! non_portable_endpoint
17367 #endif
17368                     ) {
17369                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
17370                         op = POSIXA;
17371                     }
17372                 }
17373             }
17374         }
17375
17376         /* Here, we have changed <op> away from its initial value iff we found
17377          * an optimization */
17378         if (op != END) {
17379
17380             /* Throw away this ANYOF regnode, and emit the calculated one,
17381              * which should correspond to the beginning, not current, state of
17382              * the parse */
17383             const char * cur_parse = RExC_parse;
17384             RExC_parse = (char *)orig_parse;
17385             if ( SIZE_ONLY) {
17386                 if (! LOC) {
17387
17388                     /* To get locale nodes to not use the full ANYOF size would
17389                      * require moving the code above that writes the portions
17390                      * of it that aren't in other nodes to after this point.
17391                      * e.g.  ANYOF_POSIXL_SET */
17392                     RExC_size = orig_size;
17393                 }
17394             }
17395             else {
17396                 RExC_emit = (regnode *)orig_emit;
17397                 if (PL_regkind[op] == POSIXD) {
17398                     if (op == POSIXL) {
17399                         RExC_contains_locale = 1;
17400                     }
17401                     if (invert) {
17402                         op += NPOSIXD - POSIXD;
17403                     }
17404                 }
17405             }
17406
17407             ret = reg_node(pRExC_state, op);
17408
17409             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17410                 if (! SIZE_ONLY) {
17411                     FLAGS(ret) = arg;
17412                 }
17413                 *flagp |= HASWIDTH|SIMPLE;
17414             }
17415             else if (PL_regkind[op] == EXACT) {
17416                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17417                                            TRUE /* downgradable to EXACT */
17418                                            );
17419             }
17420
17421             RExC_parse = (char *) cur_parse;
17422
17423             SvREFCNT_dec(posixes);
17424             SvREFCNT_dec(nposixes);
17425             SvREFCNT_dec(simple_posixes);
17426             SvREFCNT_dec(cp_list);
17427             SvREFCNT_dec(cp_foldable_list);
17428             return ret;
17429         }
17430     }
17431
17432     if (SIZE_ONLY)
17433         return ret;
17434     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17435
17436     /* If folding, we calculate all characters that could fold to or from the
17437      * ones already on the list */
17438     if (cp_foldable_list) {
17439         if (FOLD) {
17440             UV start, end;      /* End points of code point ranges */
17441
17442             SV* fold_intersection = NULL;
17443             SV** use_list;
17444
17445             /* Our calculated list will be for Unicode rules.  For locale
17446              * matching, we have to keep a separate list that is consulted at
17447              * runtime only when the locale indicates Unicode rules.  For
17448              * non-locale, we just use the general list */
17449             if (LOC) {
17450                 use_list = &only_utf8_locale_list;
17451             }
17452             else {
17453                 use_list = &cp_list;
17454             }
17455
17456             /* Only the characters in this class that participate in folds need
17457              * be checked.  Get the intersection of this class and all the
17458              * possible characters that are foldable.  This can quickly narrow
17459              * down a large class */
17460             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17461                                   &fold_intersection);
17462
17463             /* The folds for all the Latin1 characters are hard-coded into this
17464              * program, but we have to go out to disk to get the others. */
17465             if (invlist_highest(cp_foldable_list) >= 256) {
17466
17467                 /* This is a hash that for a particular fold gives all
17468                  * characters that are involved in it */
17469                 if (! PL_utf8_foldclosures) {
17470                     _load_PL_utf8_foldclosures();
17471                 }
17472             }
17473
17474             /* Now look at the foldable characters in this class individually */
17475             invlist_iterinit(fold_intersection);
17476             while (invlist_iternext(fold_intersection, &start, &end)) {
17477                 UV j;
17478
17479                 /* Look at every character in the range */
17480                 for (j = start; j <= end; j++) {
17481                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17482                     STRLEN foldlen;
17483                     SV** listp;
17484
17485                     if (j < 256) {
17486
17487                         if (IS_IN_SOME_FOLD_L1(j)) {
17488
17489                             /* ASCII is always matched; non-ASCII is matched
17490                              * only under Unicode rules (which could happen
17491                              * under /l if the locale is a UTF-8 one */
17492                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17493                                 *use_list = add_cp_to_invlist(*use_list,
17494                                                             PL_fold_latin1[j]);
17495                             }
17496                             else {
17497                                 has_upper_latin1_only_utf8_matches
17498                                     = add_cp_to_invlist(
17499                                             has_upper_latin1_only_utf8_matches,
17500                                             PL_fold_latin1[j]);
17501                             }
17502                         }
17503
17504                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17505                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17506                         {
17507                             add_above_Latin1_folds(pRExC_state,
17508                                                    (U8) j,
17509                                                    use_list);
17510                         }
17511                         continue;
17512                     }
17513
17514                     /* Here is an above Latin1 character.  We don't have the
17515                      * rules hard-coded for it.  First, get its fold.  This is
17516                      * the simple fold, as the multi-character folds have been
17517                      * handled earlier and separated out */
17518                     _to_uni_fold_flags(j, foldbuf, &foldlen,
17519                                                         (ASCII_FOLD_RESTRICTED)
17520                                                         ? FOLD_FLAGS_NOMIX_ASCII
17521                                                         : 0);
17522
17523                     /* Single character fold of above Latin1.  Add everything in
17524                     * its fold closure to the list that this node should match.
17525                     * The fold closures data structure is a hash with the keys
17526                     * being the UTF-8 of every character that is folded to, like
17527                     * 'k', and the values each an array of all code points that
17528                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
17529                     * Multi-character folds are not included */
17530                     if ((listp = hv_fetch(PL_utf8_foldclosures,
17531                                         (char *) foldbuf, foldlen, FALSE)))
17532                     {
17533                         AV* list = (AV*) *listp;
17534                         IV k;
17535                         for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
17536                             SV** c_p = av_fetch(list, k, FALSE);
17537                             UV c;
17538                             assert(c_p);
17539
17540                             c = SvUV(*c_p);
17541
17542                             /* /aa doesn't allow folds between ASCII and non- */
17543                             if ((ASCII_FOLD_RESTRICTED
17544                                 && (isASCII(c) != isASCII(j))))
17545                             {
17546                                 continue;
17547                             }
17548
17549                             /* Folds under /l which cross the 255/256 boundary
17550                              * are added to a separate list.  (These are valid
17551                              * only when the locale is UTF-8.) */
17552                             if (c < 256 && LOC) {
17553                                 *use_list = add_cp_to_invlist(*use_list, c);
17554                                 continue;
17555                             }
17556
17557                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17558                             {
17559                                 cp_list = add_cp_to_invlist(cp_list, c);
17560                             }
17561                             else {
17562                                 /* Similarly folds involving non-ascii Latin1
17563                                 * characters under /d are added to their list */
17564                                 has_upper_latin1_only_utf8_matches
17565                                         = add_cp_to_invlist(
17566                                            has_upper_latin1_only_utf8_matches,
17567                                            c);
17568                             }
17569                         }
17570                     }
17571                 }
17572             }
17573             SvREFCNT_dec_NN(fold_intersection);
17574         }
17575
17576         /* Now that we have finished adding all the folds, there is no reason
17577          * to keep the foldable list separate */
17578         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17579         SvREFCNT_dec_NN(cp_foldable_list);
17580     }
17581
17582     /* And combine the result (if any) with any inversion lists from posix
17583      * classes.  The lists are kept separate up to now because we don't want to
17584      * fold the classes (folding of those is automatically handled by the swash
17585      * fetching code) */
17586     if (simple_posixes) {   /* These are the classes known to be unaffected by
17587                                /a, /aa, and /d */
17588         if (cp_list) {
17589             _invlist_union(cp_list, simple_posixes, &cp_list);
17590             SvREFCNT_dec_NN(simple_posixes);
17591         }
17592         else {
17593             cp_list = simple_posixes;
17594         }
17595     }
17596     if (posixes || nposixes) {
17597
17598         /* We have to adjust /a and /aa */
17599         if (AT_LEAST_ASCII_RESTRICTED) {
17600
17601             /* Under /a and /aa, nothing above ASCII matches these */
17602             if (posixes) {
17603                 _invlist_intersection(posixes,
17604                                     PL_XPosix_ptrs[_CC_ASCII],
17605                                     &posixes);
17606             }
17607
17608             /* Under /a and /aa, everything above ASCII matches these
17609              * complements */
17610             if (nposixes) {
17611                 _invlist_union_complement_2nd(nposixes,
17612                                               PL_XPosix_ptrs[_CC_ASCII],
17613                                               &nposixes);
17614             }
17615         }
17616
17617         if (! DEPENDS_SEMANTICS) {
17618
17619             /* For everything but /d, we can just add the current 'posixes' and
17620              * 'nposixes' to the main list */
17621             if (posixes) {
17622                 if (cp_list) {
17623                     _invlist_union(cp_list, posixes, &cp_list);
17624                     SvREFCNT_dec_NN(posixes);
17625                 }
17626                 else {
17627                     cp_list = posixes;
17628                 }
17629             }
17630             if (nposixes) {
17631                 if (cp_list) {
17632                     _invlist_union(cp_list, nposixes, &cp_list);
17633                     SvREFCNT_dec_NN(nposixes);
17634                 }
17635                 else {
17636                     cp_list = nposixes;
17637                 }
17638             }
17639         }
17640         else {
17641             /* Under /d, things like \w match upper Latin1 characters only if
17642              * the target string is in UTF-8.  But things like \W match all the
17643              * upper Latin1 characters if the target string is not in UTF-8.
17644              *
17645              * Handle the case where there something like \W separately */
17646             if (nposixes) {
17647                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
17648
17649                 /* A complemented posix class matches all upper Latin1
17650                  * characters if not in UTF-8.  And it matches just certain
17651                  * ones when in UTF-8.  That means those certain ones are
17652                  * matched regardless, so can just be added to the
17653                  * unconditional list */
17654                 if (cp_list) {
17655                     _invlist_union(cp_list, nposixes, &cp_list);
17656                     SvREFCNT_dec_NN(nposixes);
17657                     nposixes = NULL;
17658                 }
17659                 else {
17660                     cp_list = nposixes;
17661                 }
17662
17663                 /* Likewise for 'posixes' */
17664                 _invlist_union(posixes, cp_list, &cp_list);
17665
17666                 /* Likewise for anything else in the range that matched only
17667                  * under UTF-8 */
17668                 if (has_upper_latin1_only_utf8_matches) {
17669                     _invlist_union(cp_list,
17670                                    has_upper_latin1_only_utf8_matches,
17671                                    &cp_list);
17672                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17673                     has_upper_latin1_only_utf8_matches = NULL;
17674                 }
17675
17676                 /* If we don't match all the upper Latin1 characters regardless
17677                  * of UTF-8ness, we have to set a flag to match the rest when
17678                  * not in UTF-8 */
17679                 _invlist_subtract(only_non_utf8_list, cp_list,
17680                                   &only_non_utf8_list);
17681                 if (_invlist_len(only_non_utf8_list) != 0) {
17682                     ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17683                 }
17684             }
17685             else {
17686                 /* Here there were no complemented posix classes.  That means
17687                  * the upper Latin1 characters in 'posixes' match only when the
17688                  * target string is in UTF-8.  So we have to add them to the
17689                  * list of those types of code points, while adding the
17690                  * remainder to the unconditional list.
17691                  *
17692                  * First calculate what they are */
17693                 SV* nonascii_but_latin1_properties = NULL;
17694                 _invlist_intersection(posixes, PL_UpperLatin1,
17695                                       &nonascii_but_latin1_properties);
17696
17697                 /* And add them to the final list of such characters. */
17698                 _invlist_union(has_upper_latin1_only_utf8_matches,
17699                                nonascii_but_latin1_properties,
17700                                &has_upper_latin1_only_utf8_matches);
17701
17702                 /* Remove them from what now becomes the unconditional list */
17703                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
17704                                   &posixes);
17705
17706                 /* And add those unconditional ones to the final list */
17707                 if (cp_list) {
17708                     _invlist_union(cp_list, posixes, &cp_list);
17709                     SvREFCNT_dec_NN(posixes);
17710                     posixes = NULL;
17711                 }
17712                 else {
17713                     cp_list = posixes;
17714                 }
17715
17716                 SvREFCNT_dec(nonascii_but_latin1_properties);
17717
17718                 /* Get rid of any characters that we now know are matched
17719                  * unconditionally from the conditional list, which may make
17720                  * that list empty */
17721                 _invlist_subtract(has_upper_latin1_only_utf8_matches,
17722                                   cp_list,
17723                                   &has_upper_latin1_only_utf8_matches);
17724                 if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
17725                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17726                     has_upper_latin1_only_utf8_matches = NULL;
17727                 }
17728             }
17729         }
17730     }
17731
17732     /* And combine the result (if any) with any inversion list from properties.
17733      * The lists are kept separate up to now so that we can distinguish the two
17734      * in regards to matching above-Unicode.  A run-time warning is generated
17735      * if a Unicode property is matched against a non-Unicode code point. But,
17736      * we allow user-defined properties to match anything, without any warning,
17737      * and we also suppress the warning if there is a portion of the character
17738      * class that isn't a Unicode property, and which matches above Unicode, \W
17739      * or [\x{110000}] for example.
17740      * (Note that in this case, unlike the Posix one above, there is no
17741      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
17742      * forces Unicode semantics */
17743     if (properties) {
17744         if (cp_list) {
17745
17746             /* If it matters to the final outcome, see if a non-property
17747              * component of the class matches above Unicode.  If so, the
17748              * warning gets suppressed.  This is true even if just a single
17749              * such code point is specified, as, though not strictly correct if
17750              * another such code point is matched against, the fact that they
17751              * are using above-Unicode code points indicates they should know
17752              * the issues involved */
17753             if (warn_super) {
17754                 warn_super = ! (invert
17755                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
17756             }
17757
17758             _invlist_union(properties, cp_list, &cp_list);
17759             SvREFCNT_dec_NN(properties);
17760         }
17761         else {
17762             cp_list = properties;
17763         }
17764
17765         if (warn_super) {
17766             ANYOF_FLAGS(ret)
17767              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17768
17769             /* Because an ANYOF node is the only one that warns, this node
17770              * can't be optimized into something else */
17771             optimizable = FALSE;
17772         }
17773     }
17774
17775     /* Here, we have calculated what code points should be in the character
17776      * class.
17777      *
17778      * Now we can see about various optimizations.  Fold calculation (which we
17779      * did above) needs to take place before inversion.  Otherwise /[^k]/i
17780      * would invert to include K, which under /i would match k, which it
17781      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
17782      * folded until runtime */
17783
17784     /* If we didn't do folding, it's because some information isn't available
17785      * until runtime; set the run-time fold flag for these.  (We don't have to
17786      * worry about properties folding, as that is taken care of by the swash
17787      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
17788      * locales, or the class matches at least one 0-255 range code point */
17789     if (LOC && FOLD) {
17790
17791         /* Some things on the list might be unconditionally included because of
17792          * other components.  Remove them, and clean up the list if it goes to
17793          * 0 elements */
17794         if (only_utf8_locale_list && cp_list) {
17795             _invlist_subtract(only_utf8_locale_list, cp_list,
17796                               &only_utf8_locale_list);
17797
17798             if (_invlist_len(only_utf8_locale_list) == 0) {
17799                 SvREFCNT_dec_NN(only_utf8_locale_list);
17800                 only_utf8_locale_list = NULL;
17801             }
17802         }
17803         if (only_utf8_locale_list) {
17804             ANYOF_FLAGS(ret)
17805                  |=  ANYOFL_FOLD
17806                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
17807         }
17808         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
17809             UV start, end;
17810             invlist_iterinit(cp_list);
17811             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
17812                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
17813             }
17814             invlist_iterfinish(cp_list);
17815         }
17816     }
17817     else if (   DEPENDS_SEMANTICS
17818              && (    has_upper_latin1_only_utf8_matches
17819                  || (ANYOF_FLAGS(ret) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
17820     {
17821         OP(ret) = ANYOFD;
17822         optimizable = FALSE;
17823     }
17824
17825
17826     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
17827      * at compile time.  Besides not inverting folded locale now, we can't
17828      * invert if there are things such as \w, which aren't known until runtime
17829      * */
17830     if (cp_list
17831         && invert
17832         && OP(ret) != ANYOFD
17833         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
17834         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17835     {
17836         _invlist_invert(cp_list);
17837
17838         /* Any swash can't be used as-is, because we've inverted things */
17839         if (swash) {
17840             SvREFCNT_dec_NN(swash);
17841             swash = NULL;
17842         }
17843
17844         /* Clear the invert flag since have just done it here */
17845         invert = FALSE;
17846     }
17847
17848     if (ret_invlist) {
17849         assert(cp_list);
17850
17851         *ret_invlist = cp_list;
17852         SvREFCNT_dec(swash);
17853
17854         /* Discard the generated node */
17855         if (SIZE_ONLY) {
17856             RExC_size = orig_size;
17857         }
17858         else {
17859             RExC_emit = orig_emit;
17860         }
17861         return orig_emit;
17862     }
17863
17864     /* Some character classes are equivalent to other nodes.  Such nodes take
17865      * up less room and generally fewer operations to execute than ANYOF nodes.
17866      * Above, we checked for and optimized into some such equivalents for
17867      * certain common classes that are easy to test.  Getting to this point in
17868      * the code means that the class didn't get optimized there.  Since this
17869      * code is only executed in Pass 2, it is too late to save space--it has
17870      * been allocated in Pass 1, and currently isn't given back.  But turning
17871      * things into an EXACTish node can allow the optimizer to join it to any
17872      * adjacent such nodes.  And if the class is equivalent to things like /./,
17873      * expensive run-time swashes can be avoided.  Now that we have more
17874      * complete information, we can find things necessarily missed by the
17875      * earlier code.  Another possible "optimization" that isn't done is that
17876      * something like [Ee] could be changed into an EXACTFU.  khw tried this
17877      * and found that the ANYOF is faster, including for code points not in the
17878      * bitmap.  This still might make sense to do, provided it got joined with
17879      * an adjacent node(s) to create a longer EXACTFU one.  This could be
17880      * accomplished by creating a pseudo ANYOF_EXACTFU node type that the join
17881      * routine would know is joinable.  If that didn't happen, the node type
17882      * could then be made a straight ANYOF */
17883
17884     if (optimizable && cp_list && ! invert) {
17885         UV start, end;
17886         U8 op = END;  /* The optimzation node-type */
17887         int posix_class = -1;   /* Illegal value */
17888         const char * cur_parse= RExC_parse;
17889
17890         invlist_iterinit(cp_list);
17891         if (! invlist_iternext(cp_list, &start, &end)) {
17892
17893             /* Here, the list is empty.  This happens, for example, when a
17894              * Unicode property that doesn't match anything is the only element
17895              * in the character class (perluniprops.pod notes such properties).
17896              * */
17897             op = OPFAIL;
17898             *flagp |= HASWIDTH|SIMPLE;
17899         }
17900         else if (start == end) {    /* The range is a single code point */
17901             if (! invlist_iternext(cp_list, &start, &end)
17902
17903                     /* Don't do this optimization if it would require changing
17904                      * the pattern to UTF-8 */
17905                 && (start < 256 || UTF))
17906             {
17907                 /* Here, the list contains a single code point.  Can optimize
17908                  * into an EXACTish node */
17909
17910                 value = start;
17911
17912                 if (! FOLD) {
17913                     op = (LOC)
17914                          ? EXACTL
17915                          : EXACT;
17916                 }
17917                 else if (LOC) {
17918
17919                     /* A locale node under folding with one code point can be
17920                      * an EXACTFL, as its fold won't be calculated until
17921                      * runtime */
17922                     op = EXACTFL;
17923                 }
17924                 else {
17925
17926                     /* Here, we are generally folding, but there is only one
17927                      * code point to match.  If we have to, we use an EXACT
17928                      * node, but it would be better for joining with adjacent
17929                      * nodes in the optimization pass if we used the same
17930                      * EXACTFish node that any such are likely to be.  We can
17931                      * do this iff the code point doesn't participate in any
17932                      * folds.  For example, an EXACTF of a colon is the same as
17933                      * an EXACT one, since nothing folds to or from a colon. */
17934                     if (value < 256) {
17935                         if (IS_IN_SOME_FOLD_L1(value)) {
17936                             op = EXACT;
17937                         }
17938                     }
17939                     else {
17940                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
17941                             op = EXACT;
17942                         }
17943                     }
17944
17945                     /* If we haven't found the node type, above, it means we
17946                      * can use the prevailing one */
17947                     if (op == END) {
17948                         op = compute_EXACTish(pRExC_state);
17949                     }
17950                 }
17951             }
17952         }   /* End of first range contains just a single code point */
17953         else if (start == 0) {
17954             if (end == UV_MAX) {
17955                 op = SANY;
17956                 *flagp |= HASWIDTH|SIMPLE;
17957                 MARK_NAUGHTY(1);
17958             }
17959             else if (end == '\n' - 1
17960                     && invlist_iternext(cp_list, &start, &end)
17961                     && start == '\n' + 1 && end == UV_MAX)
17962             {
17963                 op = REG_ANY;
17964                 *flagp |= HASWIDTH|SIMPLE;
17965                 MARK_NAUGHTY(1);
17966             }
17967         }
17968         invlist_iterfinish(cp_list);
17969
17970         if (op == END) {
17971             const UV cp_list_len = _invlist_len(cp_list);
17972             const UV* cp_list_array = invlist_array(cp_list);
17973
17974             /* Here, didn't find an optimization.  See if this matches any of
17975              * the POSIX classes.  These run slightly faster for above-Unicode
17976              * code points, so don't bother with POSIXA ones nor the 2 that
17977              * have no above-Unicode matches.  We can avoid these checks unless
17978              * the ANYOF matches at least as high as the lowest POSIX one
17979              * (which was manually found to be \v.  The actual code point may
17980              * increase in later Unicode releases, if a higher code point is
17981              * assigned to be \v, but this code will never break.  It would
17982              * just mean we could execute the checks for posix optimizations
17983              * unnecessarily) */
17984
17985             if (cp_list_array[cp_list_len-1] > 0x2029) {
17986                 for (posix_class = 0;
17987                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
17988                      posix_class++)
17989                 {
17990                     int try_inverted;
17991                     if (posix_class == _CC_ASCII || posix_class == _CC_CNTRL) {
17992                         continue;
17993                     }
17994                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
17995
17996                         /* Check if matches normal or inverted */
17997                         if (_invlistEQ(cp_list,
17998                                        PL_XPosix_ptrs[posix_class],
17999                                        try_inverted))
18000                         {
18001                             op = (try_inverted)
18002                                  ? NPOSIXU
18003                                  : POSIXU;
18004                             *flagp |= HASWIDTH|SIMPLE;
18005                             goto found_posix;
18006                         }
18007                     }
18008                 }
18009               found_posix: ;
18010             }
18011         }
18012
18013         if (op != END) {
18014             RExC_parse = (char *)orig_parse;
18015             RExC_emit = (regnode *)orig_emit;
18016
18017             if (regarglen[op]) {
18018                 ret = reganode(pRExC_state, op, 0);
18019             } else {
18020                 ret = reg_node(pRExC_state, op);
18021             }
18022
18023             RExC_parse = (char *)cur_parse;
18024
18025             if (PL_regkind[op] == EXACT) {
18026                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
18027                                            TRUE /* downgradable to EXACT */
18028                                           );
18029             }
18030             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
18031                 FLAGS(ret) = posix_class;
18032             }
18033
18034             SvREFCNT_dec_NN(cp_list);
18035             return ret;
18036         }
18037     }
18038
18039     /* Here, <cp_list> contains all the code points we can determine at
18040      * compile time that match under all conditions.  Go through it, and
18041      * for things that belong in the bitmap, put them there, and delete from
18042      * <cp_list>.  While we are at it, see if everything above 255 is in the
18043      * list, and if so, set a flag to speed up execution */
18044
18045     populate_ANYOF_from_invlist(ret, &cp_list);
18046
18047     if (invert) {
18048         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
18049     }
18050
18051     /* Here, the bitmap has been populated with all the Latin1 code points that
18052      * always match.  Can now add to the overall list those that match only
18053      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
18054      * */
18055     if (has_upper_latin1_only_utf8_matches) {
18056         if (cp_list) {
18057             _invlist_union(cp_list,
18058                            has_upper_latin1_only_utf8_matches,
18059                            &cp_list);
18060             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
18061         }
18062         else {
18063             cp_list = has_upper_latin1_only_utf8_matches;
18064         }
18065         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
18066     }
18067
18068     /* If there is a swash and more than one element, we can't use the swash in
18069      * the optimization below. */
18070     if (swash && element_count > 1) {
18071         SvREFCNT_dec_NN(swash);
18072         swash = NULL;
18073     }
18074
18075     /* Note that the optimization of using 'swash' if it is the only thing in
18076      * the class doesn't have us change swash at all, so it can include things
18077      * that are also in the bitmap; otherwise we have purposely deleted that
18078      * duplicate information */
18079     set_ANYOF_arg(pRExC_state, ret, cp_list,
18080                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
18081                    ? listsv : NULL,
18082                   only_utf8_locale_list,
18083                   swash, has_user_defined_property);
18084
18085     *flagp |= HASWIDTH|SIMPLE;
18086
18087     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
18088         RExC_contains_locale = 1;
18089     }
18090
18091     return ret;
18092 }
18093
18094 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
18095
18096 STATIC void
18097 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
18098                 regnode* const node,
18099                 SV* const cp_list,
18100                 SV* const runtime_defns,
18101                 SV* const only_utf8_locale_list,
18102                 SV* const swash,
18103                 const bool has_user_defined_property)
18104 {
18105     /* Sets the arg field of an ANYOF-type node 'node', using information about
18106      * the node passed-in.  If there is nothing outside the node's bitmap, the
18107      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
18108      * the count returned by add_data(), having allocated and stored an array,
18109      * av, that that count references, as follows:
18110      *  av[0] stores the character class description in its textual form.
18111      *        This is used later (regexec.c:Perl_regclass_swash()) to
18112      *        initialize the appropriate swash, and is also useful for dumping
18113      *        the regnode.  This is set to &PL_sv_undef if the textual
18114      *        description is not needed at run-time (as happens if the other
18115      *        elements completely define the class)
18116      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
18117      *        computed from av[0].  But if no further computation need be done,
18118      *        the swash is stored here now (and av[0] is &PL_sv_undef).
18119      *  av[2] stores the inversion list of code points that match only if the
18120      *        current locale is UTF-8
18121      *  av[3] stores the cp_list inversion list for use in addition or instead
18122      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
18123      *        (Otherwise everything needed is already in av[0] and av[1])
18124      *  av[4] is set if any component of the class is from a user-defined
18125      *        property; used only if av[3] exists */
18126
18127     UV n;
18128
18129     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
18130
18131     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
18132         assert(! (ANYOF_FLAGS(node)
18133                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
18134         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
18135     }
18136     else {
18137         AV * const av = newAV();
18138         SV *rv;
18139
18140         av_store(av, 0, (runtime_defns)
18141                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
18142         if (swash) {
18143             assert(cp_list);
18144             av_store(av, 1, swash);
18145             SvREFCNT_dec_NN(cp_list);
18146         }
18147         else {
18148             av_store(av, 1, &PL_sv_undef);
18149             if (cp_list) {
18150                 av_store(av, 3, cp_list);
18151                 av_store(av, 4, newSVuv(has_user_defined_property));
18152             }
18153         }
18154
18155         if (only_utf8_locale_list) {
18156             av_store(av, 2, only_utf8_locale_list);
18157         }
18158         else {
18159             av_store(av, 2, &PL_sv_undef);
18160         }
18161
18162         rv = newRV_noinc(MUTABLE_SV(av));
18163         n = add_data(pRExC_state, STR_WITH_LEN("s"));
18164         RExC_rxi->data->data[n] = (void*)rv;
18165         ARG_SET(node, n);
18166     }
18167 }
18168
18169 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
18170 SV *
18171 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
18172                                         const regnode* node,
18173                                         bool doinit,
18174                                         SV** listsvp,
18175                                         SV** only_utf8_locale_ptr,
18176                                         SV** output_invlist)
18177
18178 {
18179     /* For internal core use only.
18180      * Returns the swash for the input 'node' in the regex 'prog'.
18181      * If <doinit> is 'true', will attempt to create the swash if not already
18182      *    done.
18183      * If <listsvp> is non-null, will return the printable contents of the
18184      *    swash.  This can be used to get debugging information even before the
18185      *    swash exists, by calling this function with 'doinit' set to false, in
18186      *    which case the components that will be used to eventually create the
18187      *    swash are returned  (in a printable form).
18188      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
18189      *    store an inversion list of code points that should match only if the
18190      *    execution-time locale is a UTF-8 one.
18191      * If <output_invlist> is not NULL, it is where this routine is to store an
18192      *    inversion list of the code points that would be instead returned in
18193      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
18194      *    when this parameter is used, is just the non-code point data that
18195      *    will go into creating the swash.  This currently should be just
18196      *    user-defined properties whose definitions were not known at compile
18197      *    time.  Using this parameter allows for easier manipulation of the
18198      *    swash's data by the caller.  It is illegal to call this function with
18199      *    this parameter set, but not <listsvp>
18200      *
18201      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
18202      * that, in spite of this function's name, the swash it returns may include
18203      * the bitmap data as well */
18204
18205     SV *sw  = NULL;
18206     SV *si  = NULL;         /* Input swash initialization string */
18207     SV* invlist = NULL;
18208
18209     RXi_GET_DECL(prog,progi);
18210     const struct reg_data * const data = prog ? progi->data : NULL;
18211
18212     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
18213     assert(! output_invlist || listsvp);
18214
18215     if (data && data->count) {
18216         const U32 n = ARG(node);
18217
18218         if (data->what[n] == 's') {
18219             SV * const rv = MUTABLE_SV(data->data[n]);
18220             AV * const av = MUTABLE_AV(SvRV(rv));
18221             SV **const ary = AvARRAY(av);
18222             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
18223
18224             si = *ary;  /* ary[0] = the string to initialize the swash with */
18225
18226             if (av_tindex_skip_len_mg(av) >= 2) {
18227                 if (only_utf8_locale_ptr
18228                     && ary[2]
18229                     && ary[2] != &PL_sv_undef)
18230                 {
18231                     *only_utf8_locale_ptr = ary[2];
18232                 }
18233                 else {
18234                     assert(only_utf8_locale_ptr);
18235                     *only_utf8_locale_ptr = NULL;
18236                 }
18237
18238                 /* Elements 3 and 4 are either both present or both absent. [3]
18239                  * is any inversion list generated at compile time; [4]
18240                  * indicates if that inversion list has any user-defined
18241                  * properties in it. */
18242                 if (av_tindex_skip_len_mg(av) >= 3) {
18243                     invlist = ary[3];
18244                     if (SvUV(ary[4])) {
18245                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
18246                     }
18247                 }
18248                 else {
18249                     invlist = NULL;
18250                 }
18251             }
18252
18253             /* Element [1] is reserved for the set-up swash.  If already there,
18254              * return it; if not, create it and store it there */
18255             if (ary[1] && SvROK(ary[1])) {
18256                 sw = ary[1];
18257             }
18258             else if (doinit && ((si && si != &PL_sv_undef)
18259                                  || (invlist && invlist != &PL_sv_undef))) {
18260                 assert(si);
18261                 sw = _core_swash_init("utf8", /* the utf8 package */
18262                                       "", /* nameless */
18263                                       si,
18264                                       1, /* binary */
18265                                       0, /* not from tr/// */
18266                                       invlist,
18267                                       &swash_init_flags);
18268                 (void)av_store(av, 1, sw);
18269             }
18270         }
18271     }
18272
18273     /* If requested, return a printable version of what this swash matches */
18274     if (listsvp) {
18275         SV* matches_string = NULL;
18276
18277         /* The swash should be used, if possible, to get the data, as it
18278          * contains the resolved data.  But this function can be called at
18279          * compile-time, before everything gets resolved, in which case we
18280          * return the currently best available information, which is the string
18281          * that will eventually be used to do that resolving, 'si' */
18282         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
18283             && (si && si != &PL_sv_undef))
18284         {
18285             /* Here, we only have 'si' (and possibly some passed-in data in
18286              * 'invlist', which is handled below)  If the caller only wants
18287              * 'si', use that.  */
18288             if (! output_invlist) {
18289                 matches_string = newSVsv(si);
18290             }
18291             else {
18292                 /* But if the caller wants an inversion list of the node, we
18293                  * need to parse 'si' and place as much as possible in the
18294                  * desired output inversion list, making 'matches_string' only
18295                  * contain the currently unresolvable things */
18296                 const char *si_string = SvPVX(si);
18297                 STRLEN remaining = SvCUR(si);
18298                 UV prev_cp = 0;
18299                 U8 count = 0;
18300
18301                 /* Ignore everything before the first new-line */
18302                 while (*si_string != '\n' && remaining > 0) {
18303                     si_string++;
18304                     remaining--;
18305                 }
18306                 assert(remaining > 0);
18307
18308                 si_string++;
18309                 remaining--;
18310
18311                 while (remaining > 0) {
18312
18313                     /* The data consists of just strings defining user-defined
18314                      * property names, but in prior incarnations, and perhaps
18315                      * somehow from pluggable regex engines, it could still
18316                      * hold hex code point definitions.  Each component of a
18317                      * range would be separated by a tab, and each range by a
18318                      * new-line.  If these are found, instead add them to the
18319                      * inversion list */
18320                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
18321                                      |PERL_SCAN_SILENT_NON_PORTABLE;
18322                     STRLEN len = remaining;
18323                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
18324
18325                     /* If the hex decode routine found something, it should go
18326                      * up to the next \n */
18327                     if (   *(si_string + len) == '\n') {
18328                         if (count) {    /* 2nd code point on line */
18329                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
18330                         }
18331                         else {
18332                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
18333                         }
18334                         count = 0;
18335                         goto prepare_for_next_iteration;
18336                     }
18337
18338                     /* If the hex decode was instead for the lower range limit,
18339                      * save it, and go parse the upper range limit */
18340                     if (*(si_string + len) == '\t') {
18341                         assert(count == 0);
18342
18343                         prev_cp = cp;
18344                         count = 1;
18345                       prepare_for_next_iteration:
18346                         si_string += len + 1;
18347                         remaining -= len + 1;
18348                         continue;
18349                     }
18350
18351                     /* Here, didn't find a legal hex number.  Just add it from
18352                      * here to the next \n */
18353
18354                     remaining -= len;
18355                     while (*(si_string + len) != '\n' && remaining > 0) {
18356                         remaining--;
18357                         len++;
18358                     }
18359                     if (*(si_string + len) == '\n') {
18360                         len++;
18361                         remaining--;
18362                     }
18363                     if (matches_string) {
18364                         sv_catpvn(matches_string, si_string, len - 1);
18365                     }
18366                     else {
18367                         matches_string = newSVpvn(si_string, len - 1);
18368                     }
18369                     si_string += len;
18370                     sv_catpvs(matches_string, " ");
18371                 } /* end of loop through the text */
18372
18373                 assert(matches_string);
18374                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
18375                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
18376                 }
18377             } /* end of has an 'si' but no swash */
18378         }
18379
18380         /* If we have a swash in place, its equivalent inversion list was above
18381          * placed into 'invlist'.  If not, this variable may contain a stored
18382          * inversion list which is information beyond what is in 'si' */
18383         if (invlist) {
18384
18385             /* Again, if the caller doesn't want the output inversion list, put
18386              * everything in 'matches-string' */
18387             if (! output_invlist) {
18388                 if ( ! matches_string) {
18389                     matches_string = newSVpvs("\n");
18390                 }
18391                 sv_catsv(matches_string, invlist_contents(invlist,
18392                                                   TRUE /* traditional style */
18393                                                   ));
18394             }
18395             else if (! *output_invlist) {
18396                 *output_invlist = invlist_clone(invlist);
18397             }
18398             else {
18399                 _invlist_union(*output_invlist, invlist, output_invlist);
18400             }
18401         }
18402
18403         *listsvp = matches_string;
18404     }
18405
18406     return sw;
18407 }
18408 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18409
18410 /* reg_skipcomment()
18411
18412    Absorbs an /x style # comment from the input stream,
18413    returning a pointer to the first character beyond the comment, or if the
18414    comment terminates the pattern without anything following it, this returns
18415    one past the final character of the pattern (in other words, RExC_end) and
18416    sets the REG_RUN_ON_COMMENT_SEEN flag.
18417
18418    Note it's the callers responsibility to ensure that we are
18419    actually in /x mode
18420
18421 */
18422
18423 PERL_STATIC_INLINE char*
18424 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18425 {
18426     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18427
18428     assert(*p == '#');
18429
18430     while (p < RExC_end) {
18431         if (*(++p) == '\n') {
18432             return p+1;
18433         }
18434     }
18435
18436     /* we ran off the end of the pattern without ending the comment, so we have
18437      * to add an \n when wrapping */
18438     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18439     return p;
18440 }
18441
18442 STATIC void
18443 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18444                                 char ** p,
18445                                 const bool force_to_xmod
18446                          )
18447 {
18448     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18449      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18450      * is /x whitespace, advance '*p' so that on exit it points to the first
18451      * byte past all such white space and comments */
18452
18453     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18454
18455     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18456
18457     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18458
18459     for (;;) {
18460         if (RExC_end - (*p) >= 3
18461             && *(*p)     == '('
18462             && *(*p + 1) == '?'
18463             && *(*p + 2) == '#')
18464         {
18465             while (*(*p) != ')') {
18466                 if ((*p) == RExC_end)
18467                     FAIL("Sequence (?#... not terminated");
18468                 (*p)++;
18469             }
18470             (*p)++;
18471             continue;
18472         }
18473
18474         if (use_xmod) {
18475             const char * save_p = *p;
18476             while ((*p) < RExC_end) {
18477                 STRLEN len;
18478                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18479                     (*p) += len;
18480                 }
18481                 else if (*(*p) == '#') {
18482                     (*p) = reg_skipcomment(pRExC_state, (*p));
18483                 }
18484                 else {
18485                     break;
18486                 }
18487             }
18488             if (*p != save_p) {
18489                 continue;
18490             }
18491         }
18492
18493         break;
18494     }
18495
18496     return;
18497 }
18498
18499 /* nextchar()
18500
18501    Advances the parse position by one byte, unless that byte is the beginning
18502    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
18503    those two cases, the parse position is advanced beyond all such comments and
18504    white space.
18505
18506    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
18507 */
18508
18509 STATIC void
18510 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
18511 {
18512     PERL_ARGS_ASSERT_NEXTCHAR;
18513
18514     if (RExC_parse < RExC_end) {
18515         assert(   ! UTF
18516                || UTF8_IS_INVARIANT(*RExC_parse)
18517                || UTF8_IS_START(*RExC_parse));
18518
18519         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
18520
18521         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
18522                                 FALSE /* Don't force /x */ );
18523     }
18524 }
18525
18526 STATIC regnode *
18527 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
18528 {
18529     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
18530      * space.  In pass1, it aligns and increments RExC_size; in pass2,
18531      * RExC_emit */
18532
18533     regnode * const ret = RExC_emit;
18534     GET_RE_DEBUG_FLAGS_DECL;
18535
18536     PERL_ARGS_ASSERT_REGNODE_GUTS;
18537
18538     assert(extra_size >= regarglen[op]);
18539
18540     if (SIZE_ONLY) {
18541         SIZE_ALIGN(RExC_size);
18542         RExC_size += 1 + extra_size;
18543         return(ret);
18544     }
18545     if (RExC_emit >= RExC_emit_bound)
18546         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
18547                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
18548
18549     NODE_ALIGN_FILL(ret);
18550 #ifndef RE_TRACK_PATTERN_OFFSETS
18551     PERL_UNUSED_ARG(name);
18552 #else
18553     if (RExC_offsets) {         /* MJD */
18554         MJD_OFFSET_DEBUG(
18555               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
18556               name, __LINE__,
18557               PL_reg_name[op],
18558               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
18559                 ? "Overwriting end of array!\n" : "OK",
18560               (UV)(RExC_emit - RExC_emit_start),
18561               (UV)(RExC_parse - RExC_start),
18562               (UV)RExC_offsets[0]));
18563         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
18564     }
18565 #endif
18566     return(ret);
18567 }
18568
18569 /*
18570 - reg_node - emit a node
18571 */
18572 STATIC regnode *                        /* Location. */
18573 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
18574 {
18575     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
18576
18577     PERL_ARGS_ASSERT_REG_NODE;
18578
18579     assert(regarglen[op] == 0);
18580
18581     if (PASS2) {
18582         regnode *ptr = ret;
18583         FILL_ADVANCE_NODE(ptr, op);
18584         RExC_emit = ptr;
18585     }
18586     return(ret);
18587 }
18588
18589 /*
18590 - reganode - emit a node with an argument
18591 */
18592 STATIC regnode *                        /* Location. */
18593 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
18594 {
18595     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
18596
18597     PERL_ARGS_ASSERT_REGANODE;
18598
18599     assert(regarglen[op] == 1);
18600
18601     if (PASS2) {
18602         regnode *ptr = ret;
18603         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
18604         RExC_emit = ptr;
18605     }
18606     return(ret);
18607 }
18608
18609 STATIC regnode *
18610 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
18611 {
18612     /* emit a node with U32 and I32 arguments */
18613
18614     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
18615
18616     PERL_ARGS_ASSERT_REG2LANODE;
18617
18618     assert(regarglen[op] == 2);
18619
18620     if (PASS2) {
18621         regnode *ptr = ret;
18622         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
18623         RExC_emit = ptr;
18624     }
18625     return(ret);
18626 }
18627
18628 /*
18629 - reginsert - insert an operator in front of already-emitted operand
18630 *
18631 * Means relocating the operand.
18632 *
18633 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
18634 * set up NEXT_OFF() of the inserted node if needed. Something like this:
18635 *
18636 * reginsert(pRExC, OPFAIL, orig_emit, depth+1);
18637 * if (PASS2)
18638 *     NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
18639 *
18640 * ALSO NOTE - operand->flags will be set to 0 as well.
18641 */
18642 STATIC void
18643 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth)
18644 {
18645     regnode *src;
18646     regnode *dst;
18647     regnode *place;
18648     const int offset = regarglen[(U8)op];
18649     const int size = NODE_STEP_REGNODE + offset;
18650     GET_RE_DEBUG_FLAGS_DECL;
18651
18652     PERL_ARGS_ASSERT_REGINSERT;
18653     PERL_UNUSED_CONTEXT;
18654     PERL_UNUSED_ARG(depth);
18655 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
18656     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
18657     if (SIZE_ONLY) {
18658         RExC_size += size;
18659         return;
18660     }
18661     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
18662                                     studying. If this is wrong then we need to adjust RExC_recurse
18663                                     below like we do with RExC_open_parens/RExC_close_parens. */
18664     src = RExC_emit;
18665     RExC_emit += size;
18666     dst = RExC_emit;
18667     if (RExC_open_parens) {
18668         int paren;
18669         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
18670         /* remember that RExC_npar is rex->nparens + 1,
18671          * iow it is 1 more than the number of parens seen in
18672          * the pattern so far. */
18673         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
18674             /* note, RExC_open_parens[0] is the start of the
18675              * regex, it can't move. RExC_close_parens[0] is the end
18676              * of the regex, it *can* move. */
18677             if ( paren && RExC_open_parens[paren] >= operand ) {
18678                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
18679                 RExC_open_parens[paren] += size;
18680             } else {
18681                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
18682             }
18683             if ( RExC_close_parens[paren] >= operand ) {
18684                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
18685                 RExC_close_parens[paren] += size;
18686             } else {
18687                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
18688             }
18689         }
18690     }
18691     if (RExC_end_op)
18692         RExC_end_op += size;
18693
18694     while (src > operand) {
18695         StructCopy(--src, --dst, regnode);
18696 #ifdef RE_TRACK_PATTERN_OFFSETS
18697         if (RExC_offsets) {     /* MJD 20010112 */
18698             MJD_OFFSET_DEBUG(
18699                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
18700                   "reg_insert",
18701                   __LINE__,
18702                   PL_reg_name[op],
18703                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
18704                     ? "Overwriting end of array!\n" : "OK",
18705                   (UV)(src - RExC_emit_start),
18706                   (UV)(dst - RExC_emit_start),
18707                   (UV)RExC_offsets[0]));
18708             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
18709             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
18710         }
18711 #endif
18712     }
18713
18714     place = operand;            /* Op node, where operand used to be. */
18715 #ifdef RE_TRACK_PATTERN_OFFSETS
18716     if (RExC_offsets) {         /* MJD */
18717         MJD_OFFSET_DEBUG(
18718               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
18719               "reginsert",
18720               __LINE__,
18721               PL_reg_name[op],
18722               (UV)(place - RExC_emit_start) > RExC_offsets[0]
18723               ? "Overwriting end of array!\n" : "OK",
18724               (UV)(place - RExC_emit_start),
18725               (UV)(RExC_parse - RExC_start),
18726               (UV)RExC_offsets[0]));
18727         Set_Node_Offset(place, RExC_parse);
18728         Set_Node_Length(place, 1);
18729     }
18730 #endif
18731     src = NEXTOPER(place);
18732     place->flags = 0;
18733     FILL_ADVANCE_NODE(place, op);
18734     Zero(src, offset, regnode);
18735 }
18736
18737 /*
18738 - regtail - set the next-pointer at the end of a node chain of p to val.
18739 - SEE ALSO: regtail_study
18740 */
18741 STATIC void
18742 S_regtail(pTHX_ RExC_state_t * pRExC_state,
18743                 const regnode * const p,
18744                 const regnode * const val,
18745                 const U32 depth)
18746 {
18747     regnode *scan;
18748     GET_RE_DEBUG_FLAGS_DECL;
18749
18750     PERL_ARGS_ASSERT_REGTAIL;
18751 #ifndef DEBUGGING
18752     PERL_UNUSED_ARG(depth);
18753 #endif
18754
18755     if (SIZE_ONLY)
18756         return;
18757
18758     /* Find last node. */
18759     scan = (regnode *) p;
18760     for (;;) {
18761         regnode * const temp = regnext(scan);
18762         DEBUG_PARSE_r({
18763             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
18764             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18765             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
18766                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
18767                     (temp == NULL ? "->" : ""),
18768                     (temp == NULL ? PL_reg_name[OP(val)] : "")
18769             );
18770         });
18771         if (temp == NULL)
18772             break;
18773         scan = temp;
18774     }
18775
18776     if (reg_off_by_arg[OP(scan)]) {
18777         ARG_SET(scan, val - scan);
18778     }
18779     else {
18780         NEXT_OFF(scan) = val - scan;
18781     }
18782 }
18783
18784 #ifdef DEBUGGING
18785 /*
18786 - regtail_study - set the next-pointer at the end of a node chain of p to val.
18787 - Look for optimizable sequences at the same time.
18788 - currently only looks for EXACT chains.
18789
18790 This is experimental code. The idea is to use this routine to perform
18791 in place optimizations on branches and groups as they are constructed,
18792 with the long term intention of removing optimization from study_chunk so
18793 that it is purely analytical.
18794
18795 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
18796 to control which is which.
18797
18798 */
18799 /* TODO: All four parms should be const */
18800
18801 STATIC U8
18802 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
18803                       const regnode *val,U32 depth)
18804 {
18805     regnode *scan;
18806     U8 exact = PSEUDO;
18807 #ifdef EXPERIMENTAL_INPLACESCAN
18808     I32 min = 0;
18809 #endif
18810     GET_RE_DEBUG_FLAGS_DECL;
18811
18812     PERL_ARGS_ASSERT_REGTAIL_STUDY;
18813
18814
18815     if (SIZE_ONLY)
18816         return exact;
18817
18818     /* Find last node. */
18819
18820     scan = p;
18821     for (;;) {
18822         regnode * const temp = regnext(scan);
18823 #ifdef EXPERIMENTAL_INPLACESCAN
18824         if (PL_regkind[OP(scan)] == EXACT) {
18825             bool unfolded_multi_char;   /* Unexamined in this routine */
18826             if (join_exact(pRExC_state, scan, &min,
18827                            &unfolded_multi_char, 1, val, depth+1))
18828                 return EXACT;
18829         }
18830 #endif
18831         if ( exact ) {
18832             switch (OP(scan)) {
18833                 case EXACT:
18834                 case EXACTL:
18835                 case EXACTF:
18836                 case EXACTFA_NO_TRIE:
18837                 case EXACTFA:
18838                 case EXACTFU:
18839                 case EXACTFLU8:
18840                 case EXACTFU_SS:
18841                 case EXACTFL:
18842                         if( exact == PSEUDO )
18843                             exact= OP(scan);
18844                         else if ( exact != OP(scan) )
18845                             exact= 0;
18846                 case NOTHING:
18847                     break;
18848                 default:
18849                     exact= 0;
18850             }
18851         }
18852         DEBUG_PARSE_r({
18853             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
18854             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18855             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
18856                 SvPV_nolen_const(RExC_mysv),
18857                 REG_NODE_NUM(scan),
18858                 PL_reg_name[exact]);
18859         });
18860         if (temp == NULL)
18861             break;
18862         scan = temp;
18863     }
18864     DEBUG_PARSE_r({
18865         DEBUG_PARSE_MSG("");
18866         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
18867         Perl_re_printf( aTHX_
18868                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
18869                       SvPV_nolen_const(RExC_mysv),
18870                       (IV)REG_NODE_NUM(val),
18871                       (IV)(val - scan)
18872         );
18873     });
18874     if (reg_off_by_arg[OP(scan)]) {
18875         ARG_SET(scan, val - scan);
18876     }
18877     else {
18878         NEXT_OFF(scan) = val - scan;
18879     }
18880
18881     return exact;
18882 }
18883 #endif
18884
18885 /*
18886  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
18887  */
18888 #ifdef DEBUGGING
18889
18890 static void
18891 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
18892 {
18893     int bit;
18894     int set=0;
18895
18896     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18897
18898     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
18899         if (flags & (1<<bit)) {
18900             if (!set++ && lead)
18901                 Perl_re_printf( aTHX_  "%s",lead);
18902             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
18903         }
18904     }
18905     if (lead)  {
18906         if (set)
18907             Perl_re_printf( aTHX_  "\n");
18908         else
18909             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18910     }
18911 }
18912
18913 static void
18914 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
18915 {
18916     int bit;
18917     int set=0;
18918     regex_charset cs;
18919
18920     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18921
18922     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
18923         if (flags & (1<<bit)) {
18924             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
18925                 continue;
18926             }
18927             if (!set++ && lead)
18928                 Perl_re_printf( aTHX_  "%s",lead);
18929             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
18930         }
18931     }
18932     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
18933             if (!set++ && lead) {
18934                 Perl_re_printf( aTHX_  "%s",lead);
18935             }
18936             switch (cs) {
18937                 case REGEX_UNICODE_CHARSET:
18938                     Perl_re_printf( aTHX_  "UNICODE");
18939                     break;
18940                 case REGEX_LOCALE_CHARSET:
18941                     Perl_re_printf( aTHX_  "LOCALE");
18942                     break;
18943                 case REGEX_ASCII_RESTRICTED_CHARSET:
18944                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
18945                     break;
18946                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
18947                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
18948                     break;
18949                 default:
18950                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
18951                     break;
18952             }
18953     }
18954     if (lead)  {
18955         if (set)
18956             Perl_re_printf( aTHX_  "\n");
18957         else
18958             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18959     }
18960 }
18961 #endif
18962
18963 void
18964 Perl_regdump(pTHX_ const regexp *r)
18965 {
18966 #ifdef DEBUGGING
18967     int i;
18968     SV * const sv = sv_newmortal();
18969     SV *dsv= sv_newmortal();
18970     RXi_GET_DECL(r,ri);
18971     GET_RE_DEBUG_FLAGS_DECL;
18972
18973     PERL_ARGS_ASSERT_REGDUMP;
18974
18975     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
18976
18977     /* Header fields of interest. */
18978     for (i = 0; i < 2; i++) {
18979         if (r->substrs->data[i].substr) {
18980             RE_PV_QUOTED_DECL(s, 0, dsv,
18981                             SvPVX_const(r->substrs->data[i].substr),
18982                             RE_SV_DUMPLEN(r->substrs->data[i].substr),
18983                             30);
18984             Perl_re_printf( aTHX_
18985                           "%s %s%s at %" IVdf "..%" UVuf " ",
18986                           i ? "floating" : "anchored",
18987                           s,
18988                           RE_SV_TAIL(r->substrs->data[i].substr),
18989                           (IV)r->substrs->data[i].min_offset,
18990                           (UV)r->substrs->data[i].max_offset);
18991         }
18992         else if (r->substrs->data[i].utf8_substr) {
18993             RE_PV_QUOTED_DECL(s, 1, dsv,
18994                             SvPVX_const(r->substrs->data[i].utf8_substr),
18995                             RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
18996                             30);
18997             Perl_re_printf( aTHX_
18998                           "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
18999                           i ? "floating" : "anchored",
19000                           s,
19001                           RE_SV_TAIL(r->substrs->data[i].utf8_substr),
19002                           (IV)r->substrs->data[i].min_offset,
19003                           (UV)r->substrs->data[i].max_offset);
19004         }
19005     }
19006
19007     if (r->check_substr || r->check_utf8)
19008         Perl_re_printf( aTHX_
19009                       (const char *)
19010                       (   r->check_substr == r->substrs->data[1].substr
19011                        && r->check_utf8   == r->substrs->data[1].utf8_substr
19012                        ? "(checking floating" : "(checking anchored"));
19013     if (r->intflags & PREGf_NOSCAN)
19014         Perl_re_printf( aTHX_  " noscan");
19015     if (r->extflags & RXf_CHECK_ALL)
19016         Perl_re_printf( aTHX_  " isall");
19017     if (r->check_substr || r->check_utf8)
19018         Perl_re_printf( aTHX_  ") ");
19019
19020     if (ri->regstclass) {
19021         regprop(r, sv, ri->regstclass, NULL, NULL);
19022         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
19023     }
19024     if (r->intflags & PREGf_ANCH) {
19025         Perl_re_printf( aTHX_  "anchored");
19026         if (r->intflags & PREGf_ANCH_MBOL)
19027             Perl_re_printf( aTHX_  "(MBOL)");
19028         if (r->intflags & PREGf_ANCH_SBOL)
19029             Perl_re_printf( aTHX_  "(SBOL)");
19030         if (r->intflags & PREGf_ANCH_GPOS)
19031             Perl_re_printf( aTHX_  "(GPOS)");
19032         Perl_re_printf( aTHX_ " ");
19033     }
19034     if (r->intflags & PREGf_GPOS_SEEN)
19035         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
19036     if (r->intflags & PREGf_SKIP)
19037         Perl_re_printf( aTHX_  "plus ");
19038     if (r->intflags & PREGf_IMPLICIT)
19039         Perl_re_printf( aTHX_  "implicit ");
19040     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
19041     if (r->extflags & RXf_EVAL_SEEN)
19042         Perl_re_printf( aTHX_  "with eval ");
19043     Perl_re_printf( aTHX_  "\n");
19044     DEBUG_FLAGS_r({
19045         regdump_extflags("r->extflags: ",r->extflags);
19046         regdump_intflags("r->intflags: ",r->intflags);
19047     });
19048 #else
19049     PERL_ARGS_ASSERT_REGDUMP;
19050     PERL_UNUSED_CONTEXT;
19051     PERL_UNUSED_ARG(r);
19052 #endif  /* DEBUGGING */
19053 }
19054
19055 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
19056 #ifdef DEBUGGING
19057
19058 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
19059      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
19060      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
19061      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
19062      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
19063      || _CC_VERTSPACE != 15
19064 #   error Need to adjust order of anyofs[]
19065 #  endif
19066 static const char * const anyofs[] = {
19067     "\\w",
19068     "\\W",
19069     "\\d",
19070     "\\D",
19071     "[:alpha:]",
19072     "[:^alpha:]",
19073     "[:lower:]",
19074     "[:^lower:]",
19075     "[:upper:]",
19076     "[:^upper:]",
19077     "[:punct:]",
19078     "[:^punct:]",
19079     "[:print:]",
19080     "[:^print:]",
19081     "[:alnum:]",
19082     "[:^alnum:]",
19083     "[:graph:]",
19084     "[:^graph:]",
19085     "[:cased:]",
19086     "[:^cased:]",
19087     "\\s",
19088     "\\S",
19089     "[:blank:]",
19090     "[:^blank:]",
19091     "[:xdigit:]",
19092     "[:^xdigit:]",
19093     "[:cntrl:]",
19094     "[:^cntrl:]",
19095     "[:ascii:]",
19096     "[:^ascii:]",
19097     "\\v",
19098     "\\V"
19099 };
19100 #endif
19101
19102 /*
19103 - regprop - printable representation of opcode, with run time support
19104 */
19105
19106 void
19107 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
19108 {
19109 #ifdef DEBUGGING
19110     int k;
19111     RXi_GET_DECL(prog,progi);
19112     GET_RE_DEBUG_FLAGS_DECL;
19113
19114     PERL_ARGS_ASSERT_REGPROP;
19115
19116     SvPVCLEAR(sv);
19117
19118     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
19119         /* It would be nice to FAIL() here, but this may be called from
19120            regexec.c, and it would be hard to supply pRExC_state. */
19121         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19122                                               (int)OP(o), (int)REGNODE_MAX);
19123     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
19124
19125     k = PL_regkind[OP(o)];
19126
19127     if (k == EXACT) {
19128         sv_catpvs(sv, " ");
19129         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
19130          * is a crude hack but it may be the best for now since
19131          * we have no flag "this EXACTish node was UTF-8"
19132          * --jhi */
19133         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
19134                   PERL_PV_ESCAPE_UNI_DETECT |
19135                   PERL_PV_ESCAPE_NONASCII   |
19136                   PERL_PV_PRETTY_ELLIPSES   |
19137                   PERL_PV_PRETTY_LTGT       |
19138                   PERL_PV_PRETTY_NOCLEAR
19139                   );
19140     } else if (k == TRIE) {
19141         /* print the details of the trie in dumpuntil instead, as
19142          * progi->data isn't available here */
19143         const char op = OP(o);
19144         const U32 n = ARG(o);
19145         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
19146                (reg_ac_data *)progi->data->data[n] :
19147                NULL;
19148         const reg_trie_data * const trie
19149             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
19150
19151         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
19152         DEBUG_TRIE_COMPILE_r({
19153           if (trie->jump)
19154             sv_catpvs(sv, "(JUMP)");
19155           Perl_sv_catpvf(aTHX_ sv,
19156             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
19157             (UV)trie->startstate,
19158             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
19159             (UV)trie->wordcount,
19160             (UV)trie->minlen,
19161             (UV)trie->maxlen,
19162             (UV)TRIE_CHARCOUNT(trie),
19163             (UV)trie->uniquecharcount
19164           );
19165         });
19166         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
19167             sv_catpvs(sv, "[");
19168             (void) put_charclass_bitmap_innards(sv,
19169                                                 ((IS_ANYOF_TRIE(op))
19170                                                  ? ANYOF_BITMAP(o)
19171                                                  : TRIE_BITMAP(trie)),
19172                                                 NULL,
19173                                                 NULL,
19174                                                 NULL,
19175                                                 FALSE
19176                                                );
19177             sv_catpvs(sv, "]");
19178         }
19179     } else if (k == CURLY) {
19180         U32 lo = ARG1(o), hi = ARG2(o);
19181         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
19182             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
19183         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
19184         if (hi == REG_INFTY)
19185             sv_catpvs(sv, "INFTY");
19186         else
19187             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
19188         sv_catpvs(sv, "}");
19189     }
19190     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
19191         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
19192     else if (k == REF || k == OPEN || k == CLOSE
19193              || k == GROUPP || OP(o)==ACCEPT)
19194     {
19195         AV *name_list= NULL;
19196         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
19197         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
19198         if ( RXp_PAREN_NAMES(prog) ) {
19199             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19200         } else if ( pRExC_state ) {
19201             name_list= RExC_paren_name_list;
19202         }
19203         if (name_list) {
19204             if ( k != REF || (OP(o) < NREF)) {
19205                 SV **name= av_fetch(name_list, parno, 0 );
19206                 if (name)
19207                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19208             }
19209             else {
19210                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
19211                 I32 *nums=(I32*)SvPVX(sv_dat);
19212                 SV **name= av_fetch(name_list, nums[0], 0 );
19213                 I32 n;
19214                 if (name) {
19215                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
19216                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
19217                                     (n ? "," : ""), (IV)nums[n]);
19218                     }
19219                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19220                 }
19221             }
19222         }
19223         if ( k == REF && reginfo) {
19224             U32 n = ARG(o);  /* which paren pair */
19225             I32 ln = prog->offs[n].start;
19226             if (prog->lastparen < n || ln == -1)
19227                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
19228             else if (ln == prog->offs[n].end)
19229                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
19230             else {
19231                 const char *s = reginfo->strbeg + ln;
19232                 Perl_sv_catpvf(aTHX_ sv, ": ");
19233                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
19234                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
19235             }
19236         }
19237     } else if (k == GOSUB) {
19238         AV *name_list= NULL;
19239         if ( RXp_PAREN_NAMES(prog) ) {
19240             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19241         } else if ( pRExC_state ) {
19242             name_list= RExC_paren_name_list;
19243         }
19244
19245         /* Paren and offset */
19246         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
19247                 (int)((o + (int)ARG2L(o)) - progi->program) );
19248         if (name_list) {
19249             SV **name= av_fetch(name_list, ARG(o), 0 );
19250             if (name)
19251                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19252         }
19253     }
19254     else if (k == LOGICAL)
19255         /* 2: embedded, otherwise 1 */
19256         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
19257     else if (k == ANYOF) {
19258         const U8 flags = ANYOF_FLAGS(o);
19259         bool do_sep = FALSE;    /* Do we need to separate various components of
19260                                    the output? */
19261         /* Set if there is still an unresolved user-defined property */
19262         SV *unresolved                = NULL;
19263
19264         /* Things that are ignored except when the runtime locale is UTF-8 */
19265         SV *only_utf8_locale_invlist = NULL;
19266
19267         /* Code points that don't fit in the bitmap */
19268         SV *nonbitmap_invlist = NULL;
19269
19270         /* And things that aren't in the bitmap, but are small enough to be */
19271         SV* bitmap_range_not_in_bitmap = NULL;
19272
19273         const bool inverted = flags & ANYOF_INVERT;
19274
19275         if (OP(o) == ANYOFL) {
19276             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
19277                 sv_catpvs(sv, "{utf8-locale-reqd}");
19278             }
19279             if (flags & ANYOFL_FOLD) {
19280                 sv_catpvs(sv, "{i}");
19281             }
19282         }
19283
19284         /* If there is stuff outside the bitmap, get it */
19285         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
19286             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
19287                                                 &unresolved,
19288                                                 &only_utf8_locale_invlist,
19289                                                 &nonbitmap_invlist);
19290             /* The non-bitmap data may contain stuff that could fit in the
19291              * bitmap.  This could come from a user-defined property being
19292              * finally resolved when this call was done; or much more likely
19293              * because there are matches that require UTF-8 to be valid, and so
19294              * aren't in the bitmap.  This is teased apart later */
19295             _invlist_intersection(nonbitmap_invlist,
19296                                   PL_InBitmap,
19297                                   &bitmap_range_not_in_bitmap);
19298             /* Leave just the things that don't fit into the bitmap */
19299             _invlist_subtract(nonbitmap_invlist,
19300                               PL_InBitmap,
19301                               &nonbitmap_invlist);
19302         }
19303
19304         /* Obey this flag to add all above-the-bitmap code points */
19305         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
19306             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
19307                                                       NUM_ANYOF_CODE_POINTS,
19308                                                       UV_MAX);
19309         }
19310
19311         /* Ready to start outputting.  First, the initial left bracket */
19312         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19313
19314         /* Then all the things that could fit in the bitmap */
19315         do_sep = put_charclass_bitmap_innards(sv,
19316                                               ANYOF_BITMAP(o),
19317                                               bitmap_range_not_in_bitmap,
19318                                               only_utf8_locale_invlist,
19319                                               o,
19320
19321                                               /* Can't try inverting for a
19322                                                * better display if there are
19323                                                * things that haven't been
19324                                                * resolved */
19325                                               unresolved != NULL);
19326         SvREFCNT_dec(bitmap_range_not_in_bitmap);
19327
19328         /* If there are user-defined properties which haven't been defined yet,
19329          * output them.  If the result is not to be inverted, it is clearest to
19330          * output them in a separate [] from the bitmap range stuff.  If the
19331          * result is to be complemented, we have to show everything in one [],
19332          * as the inversion applies to the whole thing.  Use {braces} to
19333          * separate them from anything in the bitmap and anything above the
19334          * bitmap. */
19335         if (unresolved) {
19336             if (inverted) {
19337                 if (! do_sep) { /* If didn't output anything in the bitmap */
19338                     sv_catpvs(sv, "^");
19339                 }
19340                 sv_catpvs(sv, "{");
19341             }
19342             else if (do_sep) {
19343                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19344             }
19345             sv_catsv(sv, unresolved);
19346             if (inverted) {
19347                 sv_catpvs(sv, "}");
19348             }
19349             do_sep = ! inverted;
19350         }
19351
19352         /* And, finally, add the above-the-bitmap stuff */
19353         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
19354             SV* contents;
19355
19356             /* See if truncation size is overridden */
19357             const STRLEN dump_len = (PL_dump_re_max_len)
19358                                     ? PL_dump_re_max_len
19359                                     : 256;
19360
19361             /* This is output in a separate [] */
19362             if (do_sep) {
19363                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19364             }
19365
19366             /* And, for easy of understanding, it is shown in the
19367              * uncomplemented form if possible.  The one exception being if
19368              * there are unresolved items, where the inversion has to be
19369              * delayed until runtime */
19370             if (inverted && ! unresolved) {
19371                 _invlist_invert(nonbitmap_invlist);
19372                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
19373             }
19374
19375             contents = invlist_contents(nonbitmap_invlist,
19376                                         FALSE /* output suitable for catsv */
19377                                        );
19378
19379             /* If the output is shorter than the permissible maximum, just do it. */
19380             if (SvCUR(contents) <= dump_len) {
19381                 sv_catsv(sv, contents);
19382             }
19383             else {
19384                 const char * contents_string = SvPVX(contents);
19385                 STRLEN i = dump_len;
19386
19387                 /* Otherwise, start at the permissible max and work back to the
19388                  * first break possibility */
19389                 while (i > 0 && contents_string[i] != ' ') {
19390                     i--;
19391                 }
19392                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
19393                                        find a legal break */
19394                     i = dump_len;
19395                 }
19396
19397                 sv_catpvn(sv, contents_string, i);
19398                 sv_catpvs(sv, "...");
19399             }
19400
19401             SvREFCNT_dec_NN(contents);
19402             SvREFCNT_dec_NN(nonbitmap_invlist);
19403         }
19404
19405         /* And finally the matching, closing ']' */
19406         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19407
19408         SvREFCNT_dec(unresolved);
19409     }
19410     else if (k == POSIXD || k == NPOSIXD) {
19411         U8 index = FLAGS(o) * 2;
19412         if (index < C_ARRAY_LENGTH(anyofs)) {
19413             if (*anyofs[index] != '[')  {
19414                 sv_catpv(sv, "[");
19415             }
19416             sv_catpv(sv, anyofs[index]);
19417             if (*anyofs[index] != '[')  {
19418                 sv_catpv(sv, "]");
19419             }
19420         }
19421         else {
19422             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
19423         }
19424     }
19425     else if (k == BOUND || k == NBOUND) {
19426         /* Must be synced with order of 'bound_type' in regcomp.h */
19427         const char * const bounds[] = {
19428             "",      /* Traditional */
19429             "{gcb}",
19430             "{lb}",
19431             "{sb}",
19432             "{wb}"
19433         };
19434         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
19435         sv_catpv(sv, bounds[FLAGS(o)]);
19436     }
19437     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
19438         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
19439     else if (OP(o) == SBOL)
19440         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
19441
19442     /* add on the verb argument if there is one */
19443     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
19444         if ( ARG(o) )
19445             Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
19446                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
19447         else
19448             sv_catpvs(sv, ":NULL");
19449     }
19450 #else
19451     PERL_UNUSED_CONTEXT;
19452     PERL_UNUSED_ARG(sv);
19453     PERL_UNUSED_ARG(o);
19454     PERL_UNUSED_ARG(prog);
19455     PERL_UNUSED_ARG(reginfo);
19456     PERL_UNUSED_ARG(pRExC_state);
19457 #endif  /* DEBUGGING */
19458 }
19459
19460
19461
19462 SV *
19463 Perl_re_intuit_string(pTHX_ REGEXP * const r)
19464 {                               /* Assume that RE_INTUIT is set */
19465     struct regexp *const prog = ReANY(r);
19466     GET_RE_DEBUG_FLAGS_DECL;
19467
19468     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
19469     PERL_UNUSED_CONTEXT;
19470
19471     DEBUG_COMPILE_r(
19472         {
19473             const char * const s = SvPV_nolen_const(RX_UTF8(r)
19474                       ? prog->check_utf8 : prog->check_substr);
19475
19476             if (!PL_colorset) reginitcolors();
19477             Perl_re_printf( aTHX_
19478                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
19479                       PL_colors[4],
19480                       RX_UTF8(r) ? "utf8 " : "",
19481                       PL_colors[5],PL_colors[0],
19482                       s,
19483                       PL_colors[1],
19484                       (strlen(s) > 60 ? "..." : ""));
19485         } );
19486
19487     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
19488     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
19489 }
19490
19491 /*
19492    pregfree()
19493
19494    handles refcounting and freeing the perl core regexp structure. When
19495    it is necessary to actually free the structure the first thing it
19496    does is call the 'free' method of the regexp_engine associated to
19497    the regexp, allowing the handling of the void *pprivate; member
19498    first. (This routine is not overridable by extensions, which is why
19499    the extensions free is called first.)
19500
19501    See regdupe and regdupe_internal if you change anything here.
19502 */
19503 #ifndef PERL_IN_XSUB_RE
19504 void
19505 Perl_pregfree(pTHX_ REGEXP *r)
19506 {
19507     SvREFCNT_dec(r);
19508 }
19509
19510 void
19511 Perl_pregfree2(pTHX_ REGEXP *rx)
19512 {
19513     struct regexp *const r = ReANY(rx);
19514     GET_RE_DEBUG_FLAGS_DECL;
19515
19516     PERL_ARGS_ASSERT_PREGFREE2;
19517
19518     if (r->mother_re) {
19519         ReREFCNT_dec(r->mother_re);
19520     } else {
19521         CALLREGFREE_PVT(rx); /* free the private data */
19522         SvREFCNT_dec(RXp_PAREN_NAMES(r));
19523     }
19524     if (r->substrs) {
19525         int i;
19526         for (i = 0; i < 2; i++) {
19527             SvREFCNT_dec(r->substrs->data[i].substr);
19528             SvREFCNT_dec(r->substrs->data[i].utf8_substr);
19529         }
19530         Safefree(r->substrs);
19531     }
19532     RX_MATCH_COPY_FREE(rx);
19533 #ifdef PERL_ANY_COW
19534     SvREFCNT_dec(r->saved_copy);
19535 #endif
19536     Safefree(r->offs);
19537     SvREFCNT_dec(r->qr_anoncv);
19538     if (r->recurse_locinput)
19539         Safefree(r->recurse_locinput);
19540 }
19541
19542
19543 /*  reg_temp_copy()
19544
19545     Copy ssv to dsv, both of which should of type SVt_REGEXP or SVt_PVLV,
19546     except that dsv will be created if NULL.
19547
19548     This function is used in two main ways. First to implement
19549         $r = qr/....; $s = $$r;
19550
19551     Secondly, it is used as a hacky workaround to the structural issue of
19552     match results
19553     being stored in the regexp structure which is in turn stored in
19554     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
19555     could be PL_curpm in multiple contexts, and could require multiple
19556     result sets being associated with the pattern simultaneously, such
19557     as when doing a recursive match with (??{$qr})
19558
19559     The solution is to make a lightweight copy of the regexp structure
19560     when a qr// is returned from the code executed by (??{$qr}) this
19561     lightweight copy doesn't actually own any of its data except for
19562     the starp/end and the actual regexp structure itself.
19563
19564 */
19565
19566
19567 REGEXP *
19568 Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv)
19569 {
19570     struct regexp *drx;
19571     struct regexp *const srx = ReANY(ssv);
19572     const bool islv = dsv && SvTYPE(dsv) == SVt_PVLV;
19573
19574     PERL_ARGS_ASSERT_REG_TEMP_COPY;
19575
19576     if (!dsv)
19577         dsv = (REGEXP*) newSV_type(SVt_REGEXP);
19578     else {
19579         SvOK_off((SV *)dsv);
19580         if (islv) {
19581             /* For PVLVs, the head (sv_any) points to an XPVLV, while
19582              * the LV's xpvlenu_rx will point to a regexp body, which
19583              * we allocate here */
19584             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
19585             assert(!SvPVX(dsv));
19586             ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any;
19587             temp->sv_any = NULL;
19588             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
19589             SvREFCNT_dec_NN(temp);
19590             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
19591                ing below will not set it. */
19592             SvCUR_set(dsv, SvCUR(ssv));
19593         }
19594     }
19595     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
19596        sv_force_normal(sv) is called.  */
19597     SvFAKE_on(dsv);
19598     drx = ReANY(dsv);
19599
19600     SvFLAGS(dsv) |= SvFLAGS(ssv) & (SVf_POK|SVp_POK|SVf_UTF8);
19601     SvPV_set(dsv, RX_WRAPPED(ssv));
19602     /* We share the same string buffer as the original regexp, on which we
19603        hold a reference count, incremented when mother_re is set below.
19604        The string pointer is copied here, being part of the regexp struct.
19605      */
19606     memcpy(&(drx->xpv_cur), &(srx->xpv_cur),
19607            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
19608     if (!islv)
19609         SvLEN_set(dsv, 0);
19610     if (srx->offs) {
19611         const I32 npar = srx->nparens+1;
19612         Newx(drx->offs, npar, regexp_paren_pair);
19613         Copy(srx->offs, drx->offs, npar, regexp_paren_pair);
19614     }
19615     if (srx->substrs) {
19616         int i;
19617         Newx(drx->substrs, 1, struct reg_substr_data);
19618         StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
19619
19620         for (i = 0; i < 2; i++) {
19621             SvREFCNT_inc_void(drx->substrs->data[i].substr);
19622             SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr);
19623         }
19624
19625         /* check_substr and check_utf8, if non-NULL, point to either their
19626            anchored or float namesakes, and don't hold a second reference.  */
19627     }
19628     RX_MATCH_COPIED_off(dsv);
19629 #ifdef PERL_ANY_COW
19630     drx->saved_copy = NULL;
19631 #endif
19632     drx->mother_re = ReREFCNT_inc(srx->mother_re ? srx->mother_re : ssv);
19633     SvREFCNT_inc_void(drx->qr_anoncv);
19634     if (srx->recurse_locinput)
19635         Newxz(drx->recurse_locinput,srx->nparens + 1,char *);
19636
19637     return dsv;
19638 }
19639 #endif
19640
19641
19642 /* regfree_internal()
19643
19644    Free the private data in a regexp. This is overloadable by
19645    extensions. Perl takes care of the regexp structure in pregfree(),
19646    this covers the *pprivate pointer which technically perl doesn't
19647    know about, however of course we have to handle the
19648    regexp_internal structure when no extension is in use.
19649
19650    Note this is called before freeing anything in the regexp
19651    structure.
19652  */
19653
19654 void
19655 Perl_regfree_internal(pTHX_ REGEXP * const rx)
19656 {
19657     struct regexp *const r = ReANY(rx);
19658     RXi_GET_DECL(r,ri);
19659     GET_RE_DEBUG_FLAGS_DECL;
19660
19661     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
19662
19663     DEBUG_COMPILE_r({
19664         if (!PL_colorset)
19665             reginitcolors();
19666         {
19667             SV *dsv= sv_newmortal();
19668             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
19669                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
19670             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
19671                 PL_colors[4],PL_colors[5],s);
19672         }
19673     });
19674 #ifdef RE_TRACK_PATTERN_OFFSETS
19675     if (ri->u.offsets)
19676         Safefree(ri->u.offsets);             /* 20010421 MJD */
19677 #endif
19678     if (ri->code_blocks)
19679         S_free_codeblocks(aTHX_ ri->code_blocks);
19680
19681     if (ri->data) {
19682         int n = ri->data->count;
19683
19684         while (--n >= 0) {
19685           /* If you add a ->what type here, update the comment in regcomp.h */
19686             switch (ri->data->what[n]) {
19687             case 'a':
19688             case 'r':
19689             case 's':
19690             case 'S':
19691             case 'u':
19692                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
19693                 break;
19694             case 'f':
19695                 Safefree(ri->data->data[n]);
19696                 break;
19697             case 'l':
19698             case 'L':
19699                 break;
19700             case 'T':
19701                 { /* Aho Corasick add-on structure for a trie node.
19702                      Used in stclass optimization only */
19703                     U32 refcount;
19704                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
19705 #ifdef USE_ITHREADS
19706                     dVAR;
19707 #endif
19708                     OP_REFCNT_LOCK;
19709                     refcount = --aho->refcount;
19710                     OP_REFCNT_UNLOCK;
19711                     if ( !refcount ) {
19712                         PerlMemShared_free(aho->states);
19713                         PerlMemShared_free(aho->fail);
19714                          /* do this last!!!! */
19715                         PerlMemShared_free(ri->data->data[n]);
19716                         /* we should only ever get called once, so
19717                          * assert as much, and also guard the free
19718                          * which /might/ happen twice. At the least
19719                          * it will make code anlyzers happy and it
19720                          * doesn't cost much. - Yves */
19721                         assert(ri->regstclass);
19722                         if (ri->regstclass) {
19723                             PerlMemShared_free(ri->regstclass);
19724                             ri->regstclass = 0;
19725                         }
19726                     }
19727                 }
19728                 break;
19729             case 't':
19730                 {
19731                     /* trie structure. */
19732                     U32 refcount;
19733                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
19734 #ifdef USE_ITHREADS
19735                     dVAR;
19736 #endif
19737                     OP_REFCNT_LOCK;
19738                     refcount = --trie->refcount;
19739                     OP_REFCNT_UNLOCK;
19740                     if ( !refcount ) {
19741                         PerlMemShared_free(trie->charmap);
19742                         PerlMemShared_free(trie->states);
19743                         PerlMemShared_free(trie->trans);
19744                         if (trie->bitmap)
19745                             PerlMemShared_free(trie->bitmap);
19746                         if (trie->jump)
19747                             PerlMemShared_free(trie->jump);
19748                         PerlMemShared_free(trie->wordinfo);
19749                         /* do this last!!!! */
19750                         PerlMemShared_free(ri->data->data[n]);
19751                     }
19752                 }
19753                 break;
19754             default:
19755                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
19756                                                     ri->data->what[n]);
19757             }
19758         }
19759         Safefree(ri->data->what);
19760         Safefree(ri->data);
19761     }
19762
19763     Safefree(ri);
19764 }
19765
19766 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
19767 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
19768 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
19769
19770 /*
19771    re_dup_guts - duplicate a regexp.
19772
19773    This routine is expected to clone a given regexp structure. It is only
19774    compiled under USE_ITHREADS.
19775
19776    After all of the core data stored in struct regexp is duplicated
19777    the regexp_engine.dupe method is used to copy any private data
19778    stored in the *pprivate pointer. This allows extensions to handle
19779    any duplication it needs to do.
19780
19781    See pregfree() and regfree_internal() if you change anything here.
19782 */
19783 #if defined(USE_ITHREADS)
19784 #ifndef PERL_IN_XSUB_RE
19785 void
19786 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
19787 {
19788     dVAR;
19789     I32 npar;
19790     const struct regexp *r = ReANY(sstr);
19791     struct regexp *ret = ReANY(dstr);
19792
19793     PERL_ARGS_ASSERT_RE_DUP_GUTS;
19794
19795     npar = r->nparens+1;
19796     Newx(ret->offs, npar, regexp_paren_pair);
19797     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19798
19799     if (ret->substrs) {
19800         /* Do it this way to avoid reading from *r after the StructCopy().
19801            That way, if any of the sv_dup_inc()s dislodge *r from the L1
19802            cache, it doesn't matter.  */
19803         int i;
19804         const bool anchored = r->check_substr
19805             ? r->check_substr == r->substrs->data[0].substr
19806             : r->check_utf8   == r->substrs->data[0].utf8_substr;
19807         Newx(ret->substrs, 1, struct reg_substr_data);
19808         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19809
19810         for (i = 0; i < 2; i++) {
19811             ret->substrs->data[i].substr =
19812                         sv_dup_inc(ret->substrs->data[i].substr, param);
19813             ret->substrs->data[i].utf8_substr =
19814                         sv_dup_inc(ret->substrs->data[i].utf8_substr, param);
19815         }
19816
19817         /* check_substr and check_utf8, if non-NULL, point to either their
19818            anchored or float namesakes, and don't hold a second reference.  */
19819
19820         if (ret->check_substr) {
19821             if (anchored) {
19822                 assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
19823
19824                 ret->check_substr = ret->substrs->data[0].substr;
19825                 ret->check_utf8   = ret->substrs->data[0].utf8_substr;
19826             } else {
19827                 assert(r->check_substr == r->substrs->data[1].substr);
19828                 assert(r->check_utf8   == r->substrs->data[1].utf8_substr);
19829
19830                 ret->check_substr = ret->substrs->data[1].substr;
19831                 ret->check_utf8   = ret->substrs->data[1].utf8_substr;
19832             }
19833         } else if (ret->check_utf8) {
19834             if (anchored) {
19835                 ret->check_utf8 = ret->substrs->data[0].utf8_substr;
19836             } else {
19837                 ret->check_utf8 = ret->substrs->data[1].utf8_substr;
19838             }
19839         }
19840     }
19841
19842     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
19843     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
19844     if (r->recurse_locinput)
19845         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19846
19847     if (ret->pprivate)
19848         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
19849
19850     if (RX_MATCH_COPIED(dstr))
19851         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
19852     else
19853         ret->subbeg = NULL;
19854 #ifdef PERL_ANY_COW
19855     ret->saved_copy = NULL;
19856 #endif
19857
19858     /* Whether mother_re be set or no, we need to copy the string.  We
19859        cannot refrain from copying it when the storage points directly to
19860        our mother regexp, because that's
19861                1: a buffer in a different thread
19862                2: something we no longer hold a reference on
19863                so we need to copy it locally.  */
19864     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
19865     ret->mother_re   = NULL;
19866 }
19867 #endif /* PERL_IN_XSUB_RE */
19868
19869 /*
19870    regdupe_internal()
19871
19872    This is the internal complement to regdupe() which is used to copy
19873    the structure pointed to by the *pprivate pointer in the regexp.
19874    This is the core version of the extension overridable cloning hook.
19875    The regexp structure being duplicated will be copied by perl prior
19876    to this and will be provided as the regexp *r argument, however
19877    with the /old/ structures pprivate pointer value. Thus this routine
19878    may override any copying normally done by perl.
19879
19880    It returns a pointer to the new regexp_internal structure.
19881 */
19882
19883 void *
19884 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
19885 {
19886     dVAR;
19887     struct regexp *const r = ReANY(rx);
19888     regexp_internal *reti;
19889     int len;
19890     RXi_GET_DECL(r,ri);
19891
19892     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
19893
19894     len = ProgLen(ri);
19895
19896     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
19897           char, regexp_internal);
19898     Copy(ri->program, reti->program, len+1, regnode);
19899
19900
19901     if (ri->code_blocks) {
19902         int n;
19903         Newx(reti->code_blocks, 1, struct reg_code_blocks);
19904         Newx(reti->code_blocks->cb, ri->code_blocks->count,
19905                     struct reg_code_block);
19906         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
19907              ri->code_blocks->count, struct reg_code_block);
19908         for (n = 0; n < ri->code_blocks->count; n++)
19909              reti->code_blocks->cb[n].src_regex = (REGEXP*)
19910                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
19911         reti->code_blocks->count = ri->code_blocks->count;
19912         reti->code_blocks->refcnt = 1;
19913     }
19914     else
19915         reti->code_blocks = NULL;
19916
19917     reti->regstclass = NULL;
19918
19919     if (ri->data) {
19920         struct reg_data *d;
19921         const int count = ri->data->count;
19922         int i;
19923
19924         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
19925                 char, struct reg_data);
19926         Newx(d->what, count, U8);
19927
19928         d->count = count;
19929         for (i = 0; i < count; i++) {
19930             d->what[i] = ri->data->what[i];
19931             switch (d->what[i]) {
19932                 /* see also regcomp.h and regfree_internal() */
19933             case 'a': /* actually an AV, but the dup function is identical.
19934                          values seem to be "plain sv's" generally. */
19935             case 'r': /* a compiled regex (but still just another SV) */
19936             case 's': /* an RV (currently only used for an RV to an AV by the ANYOF code)
19937                          this use case should go away, the code could have used
19938                          'a' instead - see S_set_ANYOF_arg() for array contents. */
19939             case 'S': /* actually an SV, but the dup function is identical.  */
19940             case 'u': /* actually an HV, but the dup function is identical.
19941                          values are "plain sv's" */
19942                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
19943                 break;
19944             case 'f':
19945                 /* Synthetic Start Class - "Fake" charclass we generate to optimize
19946                  * patterns which could start with several different things. Pre-TRIE
19947                  * this was more important than it is now, however this still helps
19948                  * in some places, for instance /x?a+/ might produce a SSC equivalent
19949                  * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass()
19950                  * in regexec.c
19951                  */
19952                 /* This is cheating. */
19953                 Newx(d->data[i], 1, regnode_ssc);
19954                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
19955                 reti->regstclass = (regnode*)d->data[i];
19956                 break;
19957             case 'T':
19958                 /* AHO-CORASICK fail table */
19959                 /* Trie stclasses are readonly and can thus be shared
19960                  * without duplication. We free the stclass in pregfree
19961                  * when the corresponding reg_ac_data struct is freed.
19962                  */
19963                 reti->regstclass= ri->regstclass;
19964                 /* FALLTHROUGH */
19965             case 't':
19966                 /* TRIE transition table */
19967                 OP_REFCNT_LOCK;
19968                 ((reg_trie_data*)ri->data->data[i])->refcount++;
19969                 OP_REFCNT_UNLOCK;
19970                 /* FALLTHROUGH */
19971             case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */
19972             case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code
19973                          is not from another regexp */
19974                 d->data[i] = ri->data->data[i];
19975                 break;
19976             default:
19977                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
19978                                                            ri->data->what[i]);
19979             }
19980         }
19981
19982         reti->data = d;
19983     }
19984     else
19985         reti->data = NULL;
19986
19987     reti->name_list_idx = ri->name_list_idx;
19988
19989 #ifdef RE_TRACK_PATTERN_OFFSETS
19990     if (ri->u.offsets) {
19991         Newx(reti->u.offsets, 2*len+1, U32);
19992         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
19993     }
19994 #else
19995     SetProgLen(reti,len);
19996 #endif
19997
19998     return (void*)reti;
19999 }
20000
20001 #endif    /* USE_ITHREADS */
20002
20003 #ifndef PERL_IN_XSUB_RE
20004
20005 /*
20006  - regnext - dig the "next" pointer out of a node
20007  */
20008 regnode *
20009 Perl_regnext(pTHX_ regnode *p)
20010 {
20011     I32 offset;
20012
20013     if (!p)
20014         return(NULL);
20015
20016     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
20017         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
20018                                                 (int)OP(p), (int)REGNODE_MAX);
20019     }
20020
20021     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
20022     if (offset == 0)
20023         return(NULL);
20024
20025     return(p+offset);
20026 }
20027 #endif
20028
20029 STATIC void
20030 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
20031 {
20032     va_list args;
20033     STRLEN l1 = strlen(pat1);
20034     STRLEN l2 = strlen(pat2);
20035     char buf[512];
20036     SV *msv;
20037     const char *message;
20038
20039     PERL_ARGS_ASSERT_RE_CROAK2;
20040
20041     if (l1 > 510)
20042         l1 = 510;
20043     if (l1 + l2 > 510)
20044         l2 = 510 - l1;
20045     Copy(pat1, buf, l1 , char);
20046     Copy(pat2, buf + l1, l2 , char);
20047     buf[l1 + l2] = '\n';
20048     buf[l1 + l2 + 1] = '\0';
20049     va_start(args, pat2);
20050     msv = vmess(buf, &args);
20051     va_end(args);
20052     message = SvPV_const(msv,l1);
20053     if (l1 > 512)
20054         l1 = 512;
20055     Copy(message, buf, l1 , char);
20056     /* l1-1 to avoid \n */
20057     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
20058 }
20059
20060 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
20061
20062 #ifndef PERL_IN_XSUB_RE
20063 void
20064 Perl_save_re_context(pTHX)
20065 {
20066     I32 nparens = -1;
20067     I32 i;
20068
20069     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
20070
20071     if (PL_curpm) {
20072         const REGEXP * const rx = PM_GETRE(PL_curpm);
20073         if (rx)
20074             nparens = RX_NPARENS(rx);
20075     }
20076
20077     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
20078      * that PL_curpm will be null, but that utf8.pm and the modules it
20079      * loads will only use $1..$3.
20080      * The t/porting/re_context.t test file checks this assumption.
20081      */
20082     if (nparens == -1)
20083         nparens = 3;
20084
20085     for (i = 1; i <= nparens; i++) {
20086         char digits[TYPE_CHARS(long)];
20087         const STRLEN len = my_snprintf(digits, sizeof(digits),
20088                                        "%lu", (long)i);
20089         GV *const *const gvp
20090             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
20091
20092         if (gvp) {
20093             GV * const gv = *gvp;
20094             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
20095                 save_scalar(gv);
20096         }
20097     }
20098 }
20099 #endif
20100
20101 #ifdef DEBUGGING
20102
20103 STATIC void
20104 S_put_code_point(pTHX_ SV *sv, UV c)
20105 {
20106     PERL_ARGS_ASSERT_PUT_CODE_POINT;
20107
20108     if (c > 255) {
20109         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
20110     }
20111     else if (isPRINT(c)) {
20112         const char string = (char) c;
20113
20114         /* We use {phrase} as metanotation in the class, so also escape literal
20115          * braces */
20116         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
20117             sv_catpvs(sv, "\\");
20118         sv_catpvn(sv, &string, 1);
20119     }
20120     else if (isMNEMONIC_CNTRL(c)) {
20121         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
20122     }
20123     else {
20124         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
20125     }
20126 }
20127
20128 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
20129
20130 STATIC void
20131 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
20132 {
20133     /* Appends to 'sv' a displayable version of the range of code points from
20134      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
20135      * that have them, when they occur at the beginning or end of the range.
20136      * It uses hex to output the remaining code points, unless 'allow_literals'
20137      * is true, in which case the printable ASCII ones are output as-is (though
20138      * some of these will be escaped by put_code_point()).
20139      *
20140      * NOTE:  This is designed only for printing ranges of code points that fit
20141      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
20142      */
20143
20144     const unsigned int min_range_count = 3;
20145
20146     assert(start <= end);
20147
20148     PERL_ARGS_ASSERT_PUT_RANGE;
20149
20150     while (start <= end) {
20151         UV this_end;
20152         const char * format;
20153
20154         if (end - start < min_range_count) {
20155
20156             /* Output chars individually when they occur in short ranges */
20157             for (; start <= end; start++) {
20158                 put_code_point(sv, start);
20159             }
20160             break;
20161         }
20162
20163         /* If permitted by the input options, and there is a possibility that
20164          * this range contains a printable literal, look to see if there is
20165          * one. */
20166         if (allow_literals && start <= MAX_PRINT_A) {
20167
20168             /* If the character at the beginning of the range isn't an ASCII
20169              * printable, effectively split the range into two parts:
20170              *  1) the portion before the first such printable,
20171              *  2) the rest
20172              * and output them separately. */
20173             if (! isPRINT_A(start)) {
20174                 UV temp_end = start + 1;
20175
20176                 /* There is no point looking beyond the final possible
20177                  * printable, in MAX_PRINT_A */
20178                 UV max = MIN(end, MAX_PRINT_A);
20179
20180                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
20181                     temp_end++;
20182                 }
20183
20184                 /* Here, temp_end points to one beyond the first printable if
20185                  * found, or to one beyond 'max' if not.  If none found, make
20186                  * sure that we use the entire range */
20187                 if (temp_end > MAX_PRINT_A) {
20188                     temp_end = end + 1;
20189                 }
20190
20191                 /* Output the first part of the split range: the part that
20192                  * doesn't have printables, with the parameter set to not look
20193                  * for literals (otherwise we would infinitely recurse) */
20194                 put_range(sv, start, temp_end - 1, FALSE);
20195
20196                 /* The 2nd part of the range (if any) starts here. */
20197                 start = temp_end;
20198
20199                 /* We do a continue, instead of dropping down, because even if
20200                  * the 2nd part is non-empty, it could be so short that we want
20201                  * to output it as individual characters, as tested for at the
20202                  * top of this loop.  */
20203                 continue;
20204             }
20205
20206             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
20207              * output a sub-range of just the digits or letters, then process
20208              * the remaining portion as usual. */
20209             if (isALPHANUMERIC_A(start)) {
20210                 UV mask = (isDIGIT_A(start))
20211                            ? _CC_DIGIT
20212                              : isUPPER_A(start)
20213                                ? _CC_UPPER
20214                                : _CC_LOWER;
20215                 UV temp_end = start + 1;
20216
20217                 /* Find the end of the sub-range that includes just the
20218                  * characters in the same class as the first character in it */
20219                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
20220                     temp_end++;
20221                 }
20222                 temp_end--;
20223
20224                 /* For short ranges, don't duplicate the code above to output
20225                  * them; just call recursively */
20226                 if (temp_end - start < min_range_count) {
20227                     put_range(sv, start, temp_end, FALSE);
20228                 }
20229                 else {  /* Output as a range */
20230                     put_code_point(sv, start);
20231                     sv_catpvs(sv, "-");
20232                     put_code_point(sv, temp_end);
20233                 }
20234                 start = temp_end + 1;
20235                 continue;
20236             }
20237
20238             /* We output any other printables as individual characters */
20239             if (isPUNCT_A(start) || isSPACE_A(start)) {
20240                 while (start <= end && (isPUNCT_A(start)
20241                                         || isSPACE_A(start)))
20242                 {
20243                     put_code_point(sv, start);
20244                     start++;
20245                 }
20246                 continue;
20247             }
20248         } /* End of looking for literals */
20249
20250         /* Here is not to output as a literal.  Some control characters have
20251          * mnemonic names.  Split off any of those at the beginning and end of
20252          * the range to print mnemonically.  It isn't possible for many of
20253          * these to be in a row, so this won't overwhelm with output */
20254         if (   start <= end
20255             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
20256         {
20257             while (isMNEMONIC_CNTRL(start) && start <= end) {
20258                 put_code_point(sv, start);
20259                 start++;
20260             }
20261
20262             /* If this didn't take care of the whole range ... */
20263             if (start <= end) {
20264
20265                 /* Look backwards from the end to find the final non-mnemonic
20266                  * */
20267                 UV temp_end = end;
20268                 while (isMNEMONIC_CNTRL(temp_end)) {
20269                     temp_end--;
20270                 }
20271
20272                 /* And separately output the interior range that doesn't start
20273                  * or end with mnemonics */
20274                 put_range(sv, start, temp_end, FALSE);
20275
20276                 /* Then output the mnemonic trailing controls */
20277                 start = temp_end + 1;
20278                 while (start <= end) {
20279                     put_code_point(sv, start);
20280                     start++;
20281                 }
20282                 break;
20283             }
20284         }
20285
20286         /* As a final resort, output the range or subrange as hex. */
20287
20288         this_end = (end < NUM_ANYOF_CODE_POINTS)
20289                     ? end
20290                     : NUM_ANYOF_CODE_POINTS - 1;
20291 #if NUM_ANYOF_CODE_POINTS > 256
20292         format = (this_end < 256)
20293                  ? "\\x%02" UVXf "-\\x%02" UVXf
20294                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
20295 #else
20296         format = "\\x%02" UVXf "-\\x%02" UVXf;
20297 #endif
20298         GCC_DIAG_IGNORE(-Wformat-nonliteral);
20299         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
20300         GCC_DIAG_RESTORE;
20301         break;
20302     }
20303 }
20304
20305 STATIC void
20306 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
20307 {
20308     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
20309      * 'invlist' */
20310
20311     UV start, end;
20312     bool allow_literals = TRUE;
20313
20314     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
20315
20316     /* Generally, it is more readable if printable characters are output as
20317      * literals, but if a range (nearly) spans all of them, it's best to output
20318      * it as a single range.  This code will use a single range if all but 2
20319      * ASCII printables are in it */
20320     invlist_iterinit(invlist);
20321     while (invlist_iternext(invlist, &start, &end)) {
20322
20323         /* If the range starts beyond the final printable, it doesn't have any
20324          * in it */
20325         if (start > MAX_PRINT_A) {
20326             break;
20327         }
20328
20329         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
20330          * all but two, the range must start and end no later than 2 from
20331          * either end */
20332         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
20333             if (end > MAX_PRINT_A) {
20334                 end = MAX_PRINT_A;
20335             }
20336             if (start < ' ') {
20337                 start = ' ';
20338             }
20339             if (end - start >= MAX_PRINT_A - ' ' - 2) {
20340                 allow_literals = FALSE;
20341             }
20342             break;
20343         }
20344     }
20345     invlist_iterfinish(invlist);
20346
20347     /* Here we have figured things out.  Output each range */
20348     invlist_iterinit(invlist);
20349     while (invlist_iternext(invlist, &start, &end)) {
20350         if (start >= NUM_ANYOF_CODE_POINTS) {
20351             break;
20352         }
20353         put_range(sv, start, end, allow_literals);
20354     }
20355     invlist_iterfinish(invlist);
20356
20357     return;
20358 }
20359
20360 STATIC SV*
20361 S_put_charclass_bitmap_innards_common(pTHX_
20362         SV* invlist,            /* The bitmap */
20363         SV* posixes,            /* Under /l, things like [:word:], \S */
20364         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
20365         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
20366         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
20367         const bool invert       /* Is the result to be inverted? */
20368 )
20369 {
20370     /* Create and return an SV containing a displayable version of the bitmap
20371      * and associated information determined by the input parameters.  If the
20372      * output would have been only the inversion indicator '^', NULL is instead
20373      * returned. */
20374
20375     SV * output;
20376
20377     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
20378
20379     if (invert) {
20380         output = newSVpvs("^");
20381     }
20382     else {
20383         output = newSVpvs("");
20384     }
20385
20386     /* First, the code points in the bitmap that are unconditionally there */
20387     put_charclass_bitmap_innards_invlist(output, invlist);
20388
20389     /* Traditionally, these have been placed after the main code points */
20390     if (posixes) {
20391         sv_catsv(output, posixes);
20392     }
20393
20394     if (only_utf8 && _invlist_len(only_utf8)) {
20395         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
20396         put_charclass_bitmap_innards_invlist(output, only_utf8);
20397     }
20398
20399     if (not_utf8 && _invlist_len(not_utf8)) {
20400         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
20401         put_charclass_bitmap_innards_invlist(output, not_utf8);
20402     }
20403
20404     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
20405         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
20406         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
20407
20408         /* This is the only list in this routine that can legally contain code
20409          * points outside the bitmap range.  The call just above to
20410          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
20411          * output them here.  There's about a half-dozen possible, and none in
20412          * contiguous ranges longer than 2 */
20413         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20414             UV start, end;
20415             SV* above_bitmap = NULL;
20416
20417             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
20418
20419             invlist_iterinit(above_bitmap);
20420             while (invlist_iternext(above_bitmap, &start, &end)) {
20421                 UV i;
20422
20423                 for (i = start; i <= end; i++) {
20424                     put_code_point(output, i);
20425                 }
20426             }
20427             invlist_iterfinish(above_bitmap);
20428             SvREFCNT_dec_NN(above_bitmap);
20429         }
20430     }
20431
20432     if (invert && SvCUR(output) == 1) {
20433         return NULL;
20434     }
20435
20436     return output;
20437 }
20438
20439 STATIC bool
20440 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
20441                                      char *bitmap,
20442                                      SV *nonbitmap_invlist,
20443                                      SV *only_utf8_locale_invlist,
20444                                      const regnode * const node,
20445                                      const bool force_as_is_display)
20446 {
20447     /* Appends to 'sv' a displayable version of the innards of the bracketed
20448      * character class defined by the other arguments:
20449      *  'bitmap' points to the bitmap.
20450      *  'nonbitmap_invlist' is an inversion list of the code points that are in
20451      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
20452      *      none.  The reasons for this could be that they require some
20453      *      condition such as the target string being or not being in UTF-8
20454      *      (under /d), or because they came from a user-defined property that
20455      *      was not resolved at the time of the regex compilation (under /u)
20456      *  'only_utf8_locale_invlist' is an inversion list of the code points that
20457      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
20458      *  'node' is the regex pattern node.  It is needed only when the above two
20459      *      parameters are not null, and is passed so that this routine can
20460      *      tease apart the various reasons for them.
20461      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
20462      *      to invert things to see if that leads to a cleaner display.  If
20463      *      FALSE, this routine is free to use its judgment about doing this.
20464      *
20465      * It returns TRUE if there was actually something output.  (It may be that
20466      * the bitmap, etc is empty.)
20467      *
20468      * When called for outputting the bitmap of a non-ANYOF node, just pass the
20469      * bitmap, with the succeeding parameters set to NULL, and the final one to
20470      * FALSE.
20471      */
20472
20473     /* In general, it tries to display the 'cleanest' representation of the
20474      * innards, choosing whether to display them inverted or not, regardless of
20475      * whether the class itself is to be inverted.  However,  there are some
20476      * cases where it can't try inverting, as what actually matches isn't known
20477      * until runtime, and hence the inversion isn't either. */
20478     bool inverting_allowed = ! force_as_is_display;
20479
20480     int i;
20481     STRLEN orig_sv_cur = SvCUR(sv);
20482
20483     SV* invlist;            /* Inversion list we accumulate of code points that
20484                                are unconditionally matched */
20485     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
20486                                UTF-8 */
20487     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
20488                              */
20489     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
20490     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
20491                                        is UTF-8 */
20492
20493     SV* as_is_display;      /* The output string when we take the inputs
20494                                literally */
20495     SV* inverted_display;   /* The output string when we invert the inputs */
20496
20497     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
20498
20499     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
20500                                                    to match? */
20501     /* We are biased in favor of displaying things without them being inverted,
20502      * as that is generally easier to understand */
20503     const int bias = 5;
20504
20505     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
20506
20507     /* Start off with whatever code points are passed in.  (We clone, so we
20508      * don't change the caller's list) */
20509     if (nonbitmap_invlist) {
20510         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
20511         invlist = invlist_clone(nonbitmap_invlist);
20512     }
20513     else {  /* Worst case size is every other code point is matched */
20514         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
20515     }
20516
20517     if (flags) {
20518         if (OP(node) == ANYOFD) {
20519
20520             /* This flag indicates that the code points below 0x100 in the
20521              * nonbitmap list are precisely the ones that match only when the
20522              * target is UTF-8 (they should all be non-ASCII). */
20523             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
20524             {
20525                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
20526                 _invlist_subtract(invlist, only_utf8, &invlist);
20527             }
20528
20529             /* And this flag for matching all non-ASCII 0xFF and below */
20530             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
20531             {
20532                 not_utf8 = invlist_clone(PL_UpperLatin1);
20533             }
20534         }
20535         else if (OP(node) == ANYOFL) {
20536
20537             /* If either of these flags are set, what matches isn't
20538              * determinable except during execution, so don't know enough here
20539              * to invert */
20540             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
20541                 inverting_allowed = FALSE;
20542             }
20543
20544             /* What the posix classes match also varies at runtime, so these
20545              * will be output symbolically. */
20546             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
20547                 int i;
20548
20549                 posixes = newSVpvs("");
20550                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
20551                     if (ANYOF_POSIXL_TEST(node,i)) {
20552                         sv_catpv(posixes, anyofs[i]);
20553                     }
20554                 }
20555             }
20556         }
20557     }
20558
20559     /* Accumulate the bit map into the unconditional match list */
20560     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
20561         if (BITMAP_TEST(bitmap, i)) {
20562             int start = i++;
20563             for (; i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i); i++) {
20564                 /* empty */
20565             }
20566             invlist = _add_range_to_invlist(invlist, start, i-1);
20567         }
20568     }
20569
20570     /* Make sure that the conditional match lists don't have anything in them
20571      * that match unconditionally; otherwise the output is quite confusing.
20572      * This could happen if the code that populates these misses some
20573      * duplication. */
20574     if (only_utf8) {
20575         _invlist_subtract(only_utf8, invlist, &only_utf8);
20576     }
20577     if (not_utf8) {
20578         _invlist_subtract(not_utf8, invlist, &not_utf8);
20579     }
20580
20581     if (only_utf8_locale_invlist) {
20582
20583         /* Since this list is passed in, we have to make a copy before
20584          * modifying it */
20585         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
20586
20587         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
20588
20589         /* And, it can get really weird for us to try outputting an inverted
20590          * form of this list when it has things above the bitmap, so don't even
20591          * try */
20592         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20593             inverting_allowed = FALSE;
20594         }
20595     }
20596
20597     /* Calculate what the output would be if we take the input as-is */
20598     as_is_display = put_charclass_bitmap_innards_common(invlist,
20599                                                     posixes,
20600                                                     only_utf8,
20601                                                     not_utf8,
20602                                                     only_utf8_locale,
20603                                                     invert);
20604
20605     /* If have to take the output as-is, just do that */
20606     if (! inverting_allowed) {
20607         if (as_is_display) {
20608             sv_catsv(sv, as_is_display);
20609             SvREFCNT_dec_NN(as_is_display);
20610         }
20611     }
20612     else { /* But otherwise, create the output again on the inverted input, and
20613               use whichever version is shorter */
20614
20615         int inverted_bias, as_is_bias;
20616
20617         /* We will apply our bias to whichever of the the results doesn't have
20618          * the '^' */
20619         if (invert) {
20620             invert = FALSE;
20621             as_is_bias = bias;
20622             inverted_bias = 0;
20623         }
20624         else {
20625             invert = TRUE;
20626             as_is_bias = 0;
20627             inverted_bias = bias;
20628         }
20629
20630         /* Now invert each of the lists that contribute to the output,
20631          * excluding from the result things outside the possible range */
20632
20633         /* For the unconditional inversion list, we have to add in all the
20634          * conditional code points, so that when inverted, they will be gone
20635          * from it */
20636         _invlist_union(only_utf8, invlist, &invlist);
20637         _invlist_union(not_utf8, invlist, &invlist);
20638         _invlist_union(only_utf8_locale, invlist, &invlist);
20639         _invlist_invert(invlist);
20640         _invlist_intersection(invlist, PL_InBitmap, &invlist);
20641
20642         if (only_utf8) {
20643             _invlist_invert(only_utf8);
20644             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
20645         }
20646         else if (not_utf8) {
20647
20648             /* If a code point matches iff the target string is not in UTF-8,
20649              * then complementing the result has it not match iff not in UTF-8,
20650              * which is the same thing as matching iff it is UTF-8. */
20651             only_utf8 = not_utf8;
20652             not_utf8 = NULL;
20653         }
20654
20655         if (only_utf8_locale) {
20656             _invlist_invert(only_utf8_locale);
20657             _invlist_intersection(only_utf8_locale,
20658                                   PL_InBitmap,
20659                                   &only_utf8_locale);
20660         }
20661
20662         inverted_display = put_charclass_bitmap_innards_common(
20663                                             invlist,
20664                                             posixes,
20665                                             only_utf8,
20666                                             not_utf8,
20667                                             only_utf8_locale, invert);
20668
20669         /* Use the shortest representation, taking into account our bias
20670          * against showing it inverted */
20671         if (   inverted_display
20672             && (   ! as_is_display
20673                 || (  SvCUR(inverted_display) + inverted_bias
20674                     < SvCUR(as_is_display)    + as_is_bias)))
20675         {
20676             sv_catsv(sv, inverted_display);
20677         }
20678         else if (as_is_display) {
20679             sv_catsv(sv, as_is_display);
20680         }
20681
20682         SvREFCNT_dec(as_is_display);
20683         SvREFCNT_dec(inverted_display);
20684     }
20685
20686     SvREFCNT_dec_NN(invlist);
20687     SvREFCNT_dec(only_utf8);
20688     SvREFCNT_dec(not_utf8);
20689     SvREFCNT_dec(posixes);
20690     SvREFCNT_dec(only_utf8_locale);
20691
20692     return SvCUR(sv) > orig_sv_cur;
20693 }
20694
20695 #define CLEAR_OPTSTART                                                       \
20696     if (optstart) STMT_START {                                               \
20697         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
20698                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
20699         optstart=NULL;                                                       \
20700     } STMT_END
20701
20702 #define DUMPUNTIL(b,e)                                                       \
20703                     CLEAR_OPTSTART;                                          \
20704                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
20705
20706 STATIC const regnode *
20707 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
20708             const regnode *last, const regnode *plast,
20709             SV* sv, I32 indent, U32 depth)
20710 {
20711     U8 op = PSEUDO;     /* Arbitrary non-END op. */
20712     const regnode *next;
20713     const regnode *optstart= NULL;
20714
20715     RXi_GET_DECL(r,ri);
20716     GET_RE_DEBUG_FLAGS_DECL;
20717
20718     PERL_ARGS_ASSERT_DUMPUNTIL;
20719
20720 #ifdef DEBUG_DUMPUNTIL
20721     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
20722         last ? last-start : 0,plast ? plast-start : 0);
20723 #endif
20724
20725     if (plast && plast < last)
20726         last= plast;
20727
20728     while (PL_regkind[op] != END && (!last || node < last)) {
20729         assert(node);
20730         /* While that wasn't END last time... */
20731         NODE_ALIGN(node);
20732         op = OP(node);
20733         if (op == CLOSE || op == WHILEM)
20734             indent--;
20735         next = regnext((regnode *)node);
20736
20737         /* Where, what. */
20738         if (OP(node) == OPTIMIZED) {
20739             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
20740                 optstart = node;
20741             else
20742                 goto after_print;
20743         } else
20744             CLEAR_OPTSTART;
20745
20746         regprop(r, sv, node, NULL, NULL);
20747         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
20748                       (int)(2*indent + 1), "", SvPVX_const(sv));
20749
20750         if (OP(node) != OPTIMIZED) {
20751             if (next == NULL)           /* Next ptr. */
20752                 Perl_re_printf( aTHX_  " (0)");
20753             else if (PL_regkind[(U8)op] == BRANCH
20754                      && PL_regkind[OP(next)] != BRANCH )
20755                 Perl_re_printf( aTHX_  " (FAIL)");
20756             else
20757                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
20758             Perl_re_printf( aTHX_ "\n");
20759         }
20760
20761       after_print:
20762         if (PL_regkind[(U8)op] == BRANCHJ) {
20763             assert(next);
20764             {
20765                 const regnode *nnode = (OP(next) == LONGJMP
20766                                        ? regnext((regnode *)next)
20767                                        : next);
20768                 if (last && nnode > last)
20769                     nnode = last;
20770                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
20771             }
20772         }
20773         else if (PL_regkind[(U8)op] == BRANCH) {
20774             assert(next);
20775             DUMPUNTIL(NEXTOPER(node), next);
20776         }
20777         else if ( PL_regkind[(U8)op]  == TRIE ) {
20778             const regnode *this_trie = node;
20779             const char op = OP(node);
20780             const U32 n = ARG(node);
20781             const reg_ac_data * const ac = op>=AHOCORASICK ?
20782                (reg_ac_data *)ri->data->data[n] :
20783                NULL;
20784             const reg_trie_data * const trie =
20785                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
20786 #ifdef DEBUGGING
20787             AV *const trie_words
20788                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
20789 #endif
20790             const regnode *nextbranch= NULL;
20791             I32 word_idx;
20792             SvPVCLEAR(sv);
20793             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
20794                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
20795
20796                 Perl_re_indentf( aTHX_  "%s ",
20797                     indent+3,
20798                     elem_ptr
20799                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
20800                                 SvCUR(*elem_ptr), 60,
20801                                 PL_colors[0], PL_colors[1],
20802                                 (SvUTF8(*elem_ptr)
20803                                  ? PERL_PV_ESCAPE_UNI
20804                                  : 0)
20805                                 | PERL_PV_PRETTY_ELLIPSES
20806                                 | PERL_PV_PRETTY_LTGT
20807                             )
20808                     : "???"
20809                 );
20810                 if (trie->jump) {
20811                     U16 dist= trie->jump[word_idx+1];
20812                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
20813                                (UV)((dist ? this_trie + dist : next) - start));
20814                     if (dist) {
20815                         if (!nextbranch)
20816                             nextbranch= this_trie + trie->jump[0];
20817                         DUMPUNTIL(this_trie + dist, nextbranch);
20818                     }
20819                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
20820                         nextbranch= regnext((regnode *)nextbranch);
20821                 } else {
20822                     Perl_re_printf( aTHX_  "\n");
20823                 }
20824             }
20825             if (last && next > last)
20826                 node= last;
20827             else
20828                 node= next;
20829         }
20830         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
20831             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
20832                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
20833         }
20834         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
20835             assert(next);
20836             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
20837         }
20838         else if ( op == PLUS || op == STAR) {
20839             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
20840         }
20841         else if (PL_regkind[(U8)op] == ANYOF) {
20842             /* arglen 1 + class block */
20843             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
20844                           ? ANYOF_POSIXL_SKIP
20845                           : ANYOF_SKIP);
20846             node = NEXTOPER(node);
20847         }
20848         else if (PL_regkind[(U8)op] == EXACT) {
20849             /* Literal string, where present. */
20850             node += NODE_SZ_STR(node) - 1;
20851             node = NEXTOPER(node);
20852         }
20853         else {
20854             node = NEXTOPER(node);
20855             node += regarglen[(U8)op];
20856         }
20857         if (op == CURLYX || op == OPEN)
20858             indent++;
20859     }
20860     CLEAR_OPTSTART;
20861 #ifdef DEBUG_DUMPUNTIL
20862     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
20863 #endif
20864     return node;
20865 }
20866
20867 #endif  /* DEBUGGING */
20868
20869 /*
20870  * ex: set ts=8 sts=4 sw=4 et:
20871  */