This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix /\p{pkg::User-defined}/i
[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 #ifndef MIN
105 #define MIN(a,b) ((a) < (b) ? (a) : (b))
106 #endif
107
108 #ifndef MAX
109 #define MAX(a,b) ((a) > (b) ? (a) : (b))
110 #endif
111
112 /* this is a chain of data about sub patterns we are processing that
113    need to be handled separately/specially in study_chunk. Its so
114    we can simulate recursion without losing state.  */
115 struct scan_frame;
116 typedef struct scan_frame {
117     regnode *last_regnode;      /* last node to process in this frame */
118     regnode *next_regnode;      /* next node to process when last is reached */
119     U32 prev_recursed_depth;
120     I32 stopparen;              /* what stopparen do we use */
121     U32 is_top_frame;           /* what flags do we use? */
122
123     struct scan_frame *this_prev_frame; /* this previous frame */
124     struct scan_frame *prev_frame;      /* previous frame */
125     struct scan_frame *next_frame;      /* next frame */
126 } scan_frame;
127
128 /* Certain characters are output as a sequence with the first being a
129  * backslash. */
130 #define isBACKSLASHED_PUNCT(c)                                              \
131                     ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
132
133
134 struct RExC_state_t {
135     U32         flags;                  /* RXf_* are we folding, multilining? */
136     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
137     char        *precomp;               /* uncompiled string. */
138     char        *precomp_end;           /* pointer to end of uncompiled string. */
139     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
140     regexp      *rx;                    /* perl core regexp structure */
141     regexp_internal     *rxi;           /* internal data for regexp object
142                                            pprivate field */
143     char        *start;                 /* Start of input for compile */
144     char        *end;                   /* End of input for compile */
145     char        *parse;                 /* Input-scan pointer. */
146     char        *adjusted_start;        /* 'start', adjusted.  See code use */
147     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
148     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
149     regnode     *emit_start;            /* Start of emitted-code area */
150     regnode     *emit_bound;            /* First regnode outside of the
151                                            allocated space */
152     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
153                                            implies compiling, so don't emit */
154     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
155                                            large enough for the largest
156                                            non-EXACTish node, so can use it as
157                                            scratch in pass1 */
158     I32         naughty;                /* How bad is this pattern? */
159     I32         sawback;                /* Did we see \1, ...? */
160     U32         seen;
161     SSize_t     size;                   /* Code size. */
162     I32                npar;            /* Capture buffer count, (OPEN) plus
163                                            one. ("par" 0 is the whole
164                                            pattern)*/
165     I32         nestroot;               /* root parens we are in - used by
166                                            accept */
167     I32         extralen;
168     I32         seen_zerolen;
169     regnode     **open_parens;          /* pointers to open parens */
170     regnode     **close_parens;         /* pointers to close parens */
171     regnode     *opend;                 /* END node in program */
172     I32         utf8;           /* whether the pattern is utf8 or not */
173     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
174                                 /* XXX use this for future optimisation of case
175                                  * where pattern must be upgraded to utf8. */
176     I32         uni_semantics;  /* If a d charset modifier should use unicode
177                                    rules, even if the pattern is not in
178                                    utf8 */
179     HV          *paren_names;           /* Paren names */
180
181     regnode     **recurse;              /* Recurse regops */
182     I32         recurse_count;          /* Number of recurse regops */
183     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
184                                            through */
185     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
186     I32         in_lookbehind;
187     I32         contains_locale;
188     I32         contains_i;
189     I32         override_recoding;
190 #ifdef EBCDIC
191     I32         recode_x_to_native;
192 #endif
193     I32         in_multi_char_class;
194     struct reg_code_block *code_blocks; /* positions of literal (?{})
195                                             within pattern */
196     int         num_code_blocks;        /* size of code_blocks[] */
197     int         code_index;             /* next code_blocks[] slot */
198     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
199     scan_frame *frame_head;
200     scan_frame *frame_last;
201     U32         frame_count;
202 #ifdef ADD_TO_REGEXEC
203     char        *starttry;              /* -Dr: where regtry was called. */
204 #define RExC_starttry   (pRExC_state->starttry)
205 #endif
206     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
207 #ifdef DEBUGGING
208     const char  *lastparse;
209     I32         lastnum;
210     AV          *paren_name_list;       /* idx -> name */
211     U32         study_chunk_recursed_count;
212     SV          *mysv1;
213     SV          *mysv2;
214 #define RExC_lastparse  (pRExC_state->lastparse)
215 #define RExC_lastnum    (pRExC_state->lastnum)
216 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
217 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
218 #define RExC_mysv       (pRExC_state->mysv1)
219 #define RExC_mysv1      (pRExC_state->mysv1)
220 #define RExC_mysv2      (pRExC_state->mysv2)
221
222 #endif
223     bool        seen_unfolded_sharp_s;
224     bool        strict;
225 };
226
227 #define RExC_flags      (pRExC_state->flags)
228 #define RExC_pm_flags   (pRExC_state->pm_flags)
229 #define RExC_precomp    (pRExC_state->precomp)
230 #define RExC_precomp_adj (pRExC_state->precomp_adj)
231 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
232 #define RExC_precomp_end (pRExC_state->precomp_end)
233 #define RExC_rx_sv      (pRExC_state->rx_sv)
234 #define RExC_rx         (pRExC_state->rx)
235 #define RExC_rxi        (pRExC_state->rxi)
236 #define RExC_start      (pRExC_state->start)
237 #define RExC_end        (pRExC_state->end)
238 #define RExC_parse      (pRExC_state->parse)
239 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
240
241 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
242  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
243  * something forces the pattern into using /ui rules, the sharp s should be
244  * folded into the sequence 'ss', which takes up more space than previously
245  * calculated.  This means that the sizing pass needs to be restarted.  (The
246  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
247  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
248  * so there is no need to resize [perl #125990]. */
249 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
250
251 #ifdef RE_TRACK_PATTERN_OFFSETS
252 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
253                                                          others */
254 #endif
255 #define RExC_emit       (pRExC_state->emit)
256 #define RExC_emit_dummy (pRExC_state->emit_dummy)
257 #define RExC_emit_start (pRExC_state->emit_start)
258 #define RExC_emit_bound (pRExC_state->emit_bound)
259 #define RExC_sawback    (pRExC_state->sawback)
260 #define RExC_seen       (pRExC_state->seen)
261 #define RExC_size       (pRExC_state->size)
262 #define RExC_maxlen        (pRExC_state->maxlen)
263 #define RExC_npar       (pRExC_state->npar)
264 #define RExC_nestroot   (pRExC_state->nestroot)
265 #define RExC_extralen   (pRExC_state->extralen)
266 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
267 #define RExC_utf8       (pRExC_state->utf8)
268 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
269 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
270 #define RExC_open_parens        (pRExC_state->open_parens)
271 #define RExC_close_parens       (pRExC_state->close_parens)
272 #define RExC_opend      (pRExC_state->opend)
273 #define RExC_paren_names        (pRExC_state->paren_names)
274 #define RExC_recurse    (pRExC_state->recurse)
275 #define RExC_recurse_count      (pRExC_state->recurse_count)
276 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
277 #define RExC_study_chunk_recursed_bytes  \
278                                    (pRExC_state->study_chunk_recursed_bytes)
279 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
280 #define RExC_contains_locale    (pRExC_state->contains_locale)
281 #define RExC_contains_i (pRExC_state->contains_i)
282 #define RExC_override_recoding (pRExC_state->override_recoding)
283 #ifdef EBCDIC
284 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
285 #endif
286 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
287 #define RExC_frame_head (pRExC_state->frame_head)
288 #define RExC_frame_last (pRExC_state->frame_last)
289 #define RExC_frame_count (pRExC_state->frame_count)
290 #define RExC_strict (pRExC_state->strict)
291
292 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
293  * a flag to disable back-off on the fixed/floating substrings - if it's
294  * a high complexity pattern we assume the benefit of avoiding a full match
295  * is worth the cost of checking for the substrings even if they rarely help.
296  */
297 #define RExC_naughty    (pRExC_state->naughty)
298 #define TOO_NAUGHTY (10)
299 #define MARK_NAUGHTY(add) \
300     if (RExC_naughty < TOO_NAUGHTY) \
301         RExC_naughty += (add)
302 #define MARK_NAUGHTY_EXP(exp, add) \
303     if (RExC_naughty < TOO_NAUGHTY) \
304         RExC_naughty += RExC_naughty / (exp) + (add)
305
306 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
307 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
308         ((*s) == '{' && regcurly(s)))
309
310 /*
311  * Flags to be passed up and down.
312  */
313 #define WORST           0       /* Worst case. */
314 #define HASWIDTH        0x01    /* Known to match non-null strings. */
315
316 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
317  * character.  (There needs to be a case: in the switch statement in regexec.c
318  * for any node marked SIMPLE.)  Note that this is not the same thing as
319  * REGNODE_SIMPLE */
320 #define SIMPLE          0x02
321 #define SPSTART         0x04    /* Starts with * or + */
322 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
323 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
324 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
325 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
326                                    calcuate sizes as UTF-8 */
327
328 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
329
330 /* whether trie related optimizations are enabled */
331 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
332 #define TRIE_STUDY_OPT
333 #define FULL_TRIE_STUDY
334 #define TRIE_STCLASS
335 #endif
336
337
338
339 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
340 #define PBITVAL(paren) (1 << ((paren) & 7))
341 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
342 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
343 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
344
345 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
346                                      if (!UTF) {                           \
347                                          assert(PASS1);                    \
348                                          *flagp = RESTART_PASS1|NEED_UTF8; \
349                                          return NULL;                      \
350                                      }                                     \
351                              } STMT_END
352
353 /* Change from /d into /u rules, and restart the parse if we've already seen
354  * something whose size would increase as a result, by setting *flagp and
355  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
356  * we've change to /u during the parse.  */
357 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
358     STMT_START {                                                            \
359             if (DEPENDS_SEMANTICS) {                                        \
360                 assert(PASS1);                                              \
361                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
362                 RExC_uni_semantics = 1;                                     \
363                 if (RExC_seen_unfolded_sharp_s) {                           \
364                     *flagp |= RESTART_PASS1;                                \
365                     return restart_retval;                                  \
366                 }                                                           \
367             }                                                               \
368     } STMT_END
369
370 /* This converts the named class defined in regcomp.h to its equivalent class
371  * number defined in handy.h. */
372 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
373 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
374
375 #define _invlist_union_complement_2nd(a, b, output) \
376                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
377 #define _invlist_intersection_complement_2nd(a, b, output) \
378                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
379
380 /* About scan_data_t.
381
382   During optimisation we recurse through the regexp program performing
383   various inplace (keyhole style) optimisations. In addition study_chunk
384   and scan_commit populate this data structure with information about
385   what strings MUST appear in the pattern. We look for the longest
386   string that must appear at a fixed location, and we look for the
387   longest string that may appear at a floating location. So for instance
388   in the pattern:
389
390     /FOO[xX]A.*B[xX]BAR/
391
392   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
393   strings (because they follow a .* construct). study_chunk will identify
394   both FOO and BAR as being the longest fixed and floating strings respectively.
395
396   The strings can be composites, for instance
397
398      /(f)(o)(o)/
399
400   will result in a composite fixed substring 'foo'.
401
402   For each string some basic information is maintained:
403
404   - offset or min_offset
405     This is the position the string must appear at, or not before.
406     It also implicitly (when combined with minlenp) tells us how many
407     characters must match before the string we are searching for.
408     Likewise when combined with minlenp and the length of the string it
409     tells us how many characters must appear after the string we have
410     found.
411
412   - max_offset
413     Only used for floating strings. This is the rightmost point that
414     the string can appear at. If set to SSize_t_MAX it indicates that the
415     string can occur infinitely far to the right.
416
417   - minlenp
418     A pointer to the minimum number of characters of the pattern that the
419     string was found inside. This is important as in the case of positive
420     lookahead or positive lookbehind we can have multiple patterns
421     involved. Consider
422
423     /(?=FOO).*F/
424
425     The minimum length of the pattern overall is 3, the minimum length
426     of the lookahead part is 3, but the minimum length of the part that
427     will actually match is 1. So 'FOO's minimum length is 3, but the
428     minimum length for the F is 1. This is important as the minimum length
429     is used to determine offsets in front of and behind the string being
430     looked for.  Since strings can be composites this is the length of the
431     pattern at the time it was committed with a scan_commit. Note that
432     the length is calculated by study_chunk, so that the minimum lengths
433     are not known until the full pattern has been compiled, thus the
434     pointer to the value.
435
436   - lookbehind
437
438     In the case of lookbehind the string being searched for can be
439     offset past the start point of the final matching string.
440     If this value was just blithely removed from the min_offset it would
441     invalidate some of the calculations for how many chars must match
442     before or after (as they are derived from min_offset and minlen and
443     the length of the string being searched for).
444     When the final pattern is compiled and the data is moved from the
445     scan_data_t structure into the regexp structure the information
446     about lookbehind is factored in, with the information that would
447     have been lost precalculated in the end_shift field for the
448     associated string.
449
450   The fields pos_min and pos_delta are used to store the minimum offset
451   and the delta to the maximum offset at the current point in the pattern.
452
453 */
454
455 typedef struct scan_data_t {
456     /*I32 len_min;      unused */
457     /*I32 len_delta;    unused */
458     SSize_t pos_min;
459     SSize_t pos_delta;
460     SV *last_found;
461     SSize_t last_end;       /* min value, <0 unless valid. */
462     SSize_t last_start_min;
463     SSize_t last_start_max;
464     SV **longest;           /* Either &l_fixed, or &l_float. */
465     SV *longest_fixed;      /* longest fixed string found in pattern */
466     SSize_t offset_fixed;   /* offset where it starts */
467     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
468     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
469     SV *longest_float;      /* longest floating string found in pattern */
470     SSize_t offset_float_min; /* earliest point in string it can appear */
471     SSize_t offset_float_max; /* latest point in string it can appear */
472     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
473     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
474     I32 flags;
475     I32 whilem_c;
476     SSize_t *last_closep;
477     regnode_ssc *start_class;
478 } scan_data_t;
479
480 /*
481  * Forward declarations for pregcomp()'s friends.
482  */
483
484 static const scan_data_t zero_scan_data =
485   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
486
487 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
488 #define SF_BEFORE_SEOL          0x0001
489 #define SF_BEFORE_MEOL          0x0002
490 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
491 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
492
493 #define SF_FIX_SHIFT_EOL        (+2)
494 #define SF_FL_SHIFT_EOL         (+4)
495
496 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
497 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
498
499 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
500 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
501 #define SF_IS_INF               0x0040
502 #define SF_HAS_PAR              0x0080
503 #define SF_IN_PAR               0x0100
504 #define SF_HAS_EVAL             0x0200
505 #define SCF_DO_SUBSTR           0x0400
506 #define SCF_DO_STCLASS_AND      0x0800
507 #define SCF_DO_STCLASS_OR       0x1000
508 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
509 #define SCF_WHILEM_VISITED_POS  0x2000
510
511 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
512 #define SCF_SEEN_ACCEPT         0x8000
513 #define SCF_TRIE_DOING_RESTUDY 0x10000
514 #define SCF_IN_DEFINE          0x20000
515
516
517
518
519 #define UTF cBOOL(RExC_utf8)
520
521 /* The enums for all these are ordered so things work out correctly */
522 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
523 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
524                                                      == REGEX_DEPENDS_CHARSET)
525 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
526 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
527                                                      >= REGEX_UNICODE_CHARSET)
528 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
529                                             == REGEX_ASCII_RESTRICTED_CHARSET)
530 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
531                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
532 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
533                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
534
535 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
536
537 /* For programs that want to be strictly Unicode compatible by dying if any
538  * attempt is made to match a non-Unicode code point against a Unicode
539  * property.  */
540 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
541
542 #define OOB_NAMEDCLASS          -1
543
544 /* There is no code point that is out-of-bounds, so this is problematic.  But
545  * its only current use is to initialize a variable that is always set before
546  * looked at. */
547 #define OOB_UNICODE             0xDEADBEEF
548
549 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
550 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
551
552
553 /* length of regex to show in messages that don't mark a position within */
554 #define RegexLengthToShowInErrorMessages 127
555
556 /*
557  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
558  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
559  * op/pragma/warn/regcomp.
560  */
561 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
562 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
563
564 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
565                         " in m/%"UTF8f MARKER2 "%"UTF8f"/"
566
567 /* The code in this file in places uses one level of recursion with parsing
568  * rebased to an alternate string constructed by us in memory.  This can take
569  * the form of something that is completely different from the input, or
570  * something that uses the input as part of the alternate.  In the first case,
571  * there should be no possibility of an error, as we are in complete control of
572  * the alternate string.  But in the second case we don't control the input
573  * portion, so there may be errors in that.  Here's an example:
574  *      /[abc\x{DF}def]/ui
575  * is handled specially because \x{df} folds to a sequence of more than one
576  * character, 'ss'.  What is done is to create and parse an alternate string,
577  * which looks like this:
578  *      /(?:\x{DF}|[abc\x{DF}def])/ui
579  * where it uses the input unchanged in the middle of something it constructs,
580  * which is a branch for the DF outside the character class, and clustering
581  * parens around the whole thing. (It knows enough to skip the DF inside the
582  * class while in this substitute parse.) 'abc' and 'def' may have errors that
583  * need to be reported.  The general situation looks like this:
584  *
585  *              sI                       tI               xI       eI
586  * Input:       ----------------------------------------------------
587  * Constructed:         ---------------------------------------------------
588  *                      sC               tC               xC       eC     EC
589  *
590  * The input string sI..eI is the input pattern.  The string sC..EC is the
591  * constructed substitute parse string.  The portions sC..tC and eC..EC are
592  * constructed by us.  The portion tC..eC is an exact duplicate of the input
593  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
594  * while parsing, we find an error at xC.  We want to display a message showing
595  * the real input string.  Thus we need to find the point xI in it which
596  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
597  * been constructed by us, and so shouldn't have errors.  We get:
598  *
599  *      xI = sI + (tI - sI) + (xC - tC)
600  *
601  * and, the offset into sI is:
602  *
603  *      (xI - sI) = (tI - sI) + (xC - tC)
604  *
605  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
606  * and we save tC as RExC_adjusted_start.
607  *
608  * During normal processing of the input pattern, everything points to that,
609  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
610  */
611
612 #define tI_sI           RExC_precomp_adj
613 #define tC              RExC_adjusted_start
614 #define sC              RExC_precomp
615 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
616 #define xI(xC)          (sC + xI_offset(xC))
617 #define eC              RExC_precomp_end
618
619 #define REPORT_LOCATION_ARGS(xC)                                            \
620     UTF8fARG(UTF,                                                           \
621              (xI(xC) > eC) /* Don't run off end */                          \
622               ? eC - sC   /* Length before the <--HERE */                   \
623               : xI_offset(xC),                                              \
624              sC),         /* The input pattern printed up to the <--HERE */ \
625     UTF8fARG(UTF,                                                           \
626              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
627              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
628
629 /* Used to point after bad bytes for an error message, but avoid skipping
630  * past a nul byte. */
631 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
632
633 /*
634  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
635  * arg. Show regex, up to a maximum length. If it's too long, chop and add
636  * "...".
637  */
638 #define _FAIL(code) STMT_START {                                        \
639     const char *ellipses = "";                                          \
640     IV len = RExC_precomp_end - RExC_precomp;                                   \
641                                                                         \
642     if (!SIZE_ONLY)                                                     \
643         SAVEFREESV(RExC_rx_sv);                                         \
644     if (len > RegexLengthToShowInErrorMessages) {                       \
645         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
646         len = RegexLengthToShowInErrorMessages - 10;                    \
647         ellipses = "...";                                               \
648     }                                                                   \
649     code;                                                               \
650 } STMT_END
651
652 #define FAIL(msg) _FAIL(                            \
653     Perl_croak(aTHX_ "%s in regex m/%"UTF8f"%s/",           \
654             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
655
656 #define FAIL2(msg,arg) _FAIL(                       \
657     Perl_croak(aTHX_ msg " in regex m/%"UTF8f"%s/",         \
658             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
659
660 /*
661  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
662  */
663 #define Simple_vFAIL(m) STMT_START {                                    \
664     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
665             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
666 } STMT_END
667
668 /*
669  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
670  */
671 #define vFAIL(m) STMT_START {                           \
672     if (!SIZE_ONLY)                                     \
673         SAVEFREESV(RExC_rx_sv);                         \
674     Simple_vFAIL(m);                                    \
675 } STMT_END
676
677 /*
678  * Like Simple_vFAIL(), but accepts two arguments.
679  */
680 #define Simple_vFAIL2(m,a1) STMT_START {                        \
681     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
682                       REPORT_LOCATION_ARGS(RExC_parse));        \
683 } STMT_END
684
685 /*
686  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
687  */
688 #define vFAIL2(m,a1) STMT_START {                       \
689     if (!SIZE_ONLY)                                     \
690         SAVEFREESV(RExC_rx_sv);                         \
691     Simple_vFAIL2(m, a1);                               \
692 } STMT_END
693
694
695 /*
696  * Like Simple_vFAIL(), but accepts three arguments.
697  */
698 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
699     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
700             REPORT_LOCATION_ARGS(RExC_parse));                  \
701 } STMT_END
702
703 /*
704  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
705  */
706 #define vFAIL3(m,a1,a2) STMT_START {                    \
707     if (!SIZE_ONLY)                                     \
708         SAVEFREESV(RExC_rx_sv);                         \
709     Simple_vFAIL3(m, a1, a2);                           \
710 } STMT_END
711
712 /*
713  * Like Simple_vFAIL(), but accepts four arguments.
714  */
715 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
716     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
717             REPORT_LOCATION_ARGS(RExC_parse));                  \
718 } STMT_END
719
720 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
721     if (!SIZE_ONLY)                                     \
722         SAVEFREESV(RExC_rx_sv);                         \
723     Simple_vFAIL4(m, a1, a2, a3);                       \
724 } STMT_END
725
726 /* A specialized version of vFAIL2 that works with UTF8f */
727 #define vFAIL2utf8f(m, a1) STMT_START {             \
728     if (!SIZE_ONLY)                                 \
729         SAVEFREESV(RExC_rx_sv);                     \
730     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
731             REPORT_LOCATION_ARGS(RExC_parse));      \
732 } STMT_END
733
734 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
735     if (!SIZE_ONLY)                                     \
736         SAVEFREESV(RExC_rx_sv);                         \
737     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
738             REPORT_LOCATION_ARGS(RExC_parse));          \
739 } STMT_END
740
741 /* These have asserts in them because of [perl #122671] Many warnings in
742  * regcomp.c can occur twice.  If they get output in pass1 and later in that
743  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
744  * would get output again.  So they should be output in pass2, and these
745  * asserts make sure new warnings follow that paradigm. */
746
747 /* m is not necessarily a "literal string", in this macro */
748 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
749     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
750                                        "%s" REPORT_LOCATION,            \
751                                   m, REPORT_LOCATION_ARGS(loc));        \
752 } STMT_END
753
754 #define ckWARNreg(loc,m) STMT_START {                                   \
755     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
756                                           m REPORT_LOCATION,            \
757                                           REPORT_LOCATION_ARGS(loc));   \
758 } STMT_END
759
760 #define vWARN(loc, m) STMT_START {                                      \
761     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
762                                        m REPORT_LOCATION,               \
763                                        REPORT_LOCATION_ARGS(loc));      \
764 } STMT_END
765
766 #define vWARN_dep(loc, m) STMT_START {                                  \
767     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
768                                        m REPORT_LOCATION,               \
769                                        REPORT_LOCATION_ARGS(loc));      \
770 } STMT_END
771
772 #define ckWARNdep(loc,m) STMT_START {                                   \
773     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
774                                             m REPORT_LOCATION,          \
775                                             REPORT_LOCATION_ARGS(loc)); \
776 } STMT_END
777
778 #define ckWARNregdep(loc,m) STMT_START {                                    \
779     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
780                                                       WARN_REGEXP),         \
781                                              m REPORT_LOCATION,             \
782                                              REPORT_LOCATION_ARGS(loc));    \
783 } STMT_END
784
785 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
786     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
787                                             m REPORT_LOCATION,              \
788                                             a1, REPORT_LOCATION_ARGS(loc)); \
789 } STMT_END
790
791 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
792     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
793                                           m REPORT_LOCATION,                \
794                                           a1, REPORT_LOCATION_ARGS(loc));   \
795 } STMT_END
796
797 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
798     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
799                                        m REPORT_LOCATION,                   \
800                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
801 } STMT_END
802
803 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
804     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
805                                           m REPORT_LOCATION,                \
806                                           a1, a2,                           \
807                                           REPORT_LOCATION_ARGS(loc));       \
808 } STMT_END
809
810 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
811     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
812                                        m REPORT_LOCATION,               \
813                                        a1, a2, a3,                      \
814                                        REPORT_LOCATION_ARGS(loc));      \
815 } STMT_END
816
817 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
818     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
819                                           m REPORT_LOCATION,            \
820                                           a1, a2, a3,                   \
821                                           REPORT_LOCATION_ARGS(loc));   \
822 } STMT_END
823
824 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
825     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
826                                        m REPORT_LOCATION,               \
827                                        a1, a2, a3, a4,                  \
828                                        REPORT_LOCATION_ARGS(loc));      \
829 } STMT_END
830
831 /* Macros for recording node offsets.   20001227 mjd@plover.com
832  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
833  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
834  * Element 0 holds the number n.
835  * Position is 1 indexed.
836  */
837 #ifndef RE_TRACK_PATTERN_OFFSETS
838 #define Set_Node_Offset_To_R(node,byte)
839 #define Set_Node_Offset(node,byte)
840 #define Set_Cur_Node_Offset
841 #define Set_Node_Length_To_R(node,len)
842 #define Set_Node_Length(node,len)
843 #define Set_Node_Cur_Length(node,start)
844 #define Node_Offset(n)
845 #define Node_Length(n)
846 #define Set_Node_Offset_Length(node,offset,len)
847 #define ProgLen(ri) ri->u.proglen
848 #define SetProgLen(ri,x) ri->u.proglen = x
849 #else
850 #define ProgLen(ri) ri->u.offsets[0]
851 #define SetProgLen(ri,x) ri->u.offsets[0] = x
852 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
853     if (! SIZE_ONLY) {                                                  \
854         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
855                     __LINE__, (int)(node), (int)(byte)));               \
856         if((node) < 0) {                                                \
857             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
858                                          (int)(node));                  \
859         } else {                                                        \
860             RExC_offsets[2*(node)-1] = (byte);                          \
861         }                                                               \
862     }                                                                   \
863 } STMT_END
864
865 #define Set_Node_Offset(node,byte) \
866     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
867 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
868
869 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
870     if (! SIZE_ONLY) {                                                  \
871         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
872                 __LINE__, (int)(node), (int)(len)));                    \
873         if((node) < 0) {                                                \
874             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
875                                          (int)(node));                  \
876         } else {                                                        \
877             RExC_offsets[2*(node)] = (len);                             \
878         }                                                               \
879     }                                                                   \
880 } STMT_END
881
882 #define Set_Node_Length(node,len) \
883     Set_Node_Length_To_R((node)-RExC_emit_start, len)
884 #define Set_Node_Cur_Length(node, start)                \
885     Set_Node_Length(node, RExC_parse - start)
886
887 /* Get offsets and lengths */
888 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
889 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
890
891 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
892     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
893     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
894 } STMT_END
895 #endif
896
897 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
898 #define EXPERIMENTAL_INPLACESCAN
899 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
900
901 #define DEBUG_RExC_seen() \
902         DEBUG_OPTIMISE_MORE_r({                                             \
903             PerlIO_printf(Perl_debug_log,"RExC_seen: ");                    \
904                                                                             \
905             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
906                 PerlIO_printf(Perl_debug_log,"REG_ZERO_LEN_SEEN ");         \
907                                                                             \
908             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
909                 PerlIO_printf(Perl_debug_log,"REG_LOOKBEHIND_SEEN ");       \
910                                                                             \
911             if (RExC_seen & REG_GPOS_SEEN)                                  \
912                 PerlIO_printf(Perl_debug_log,"REG_GPOS_SEEN ");             \
913                                                                             \
914             if (RExC_seen & REG_RECURSE_SEEN)                               \
915                 PerlIO_printf(Perl_debug_log,"REG_RECURSE_SEEN ");          \
916                                                                             \
917             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                         \
918                 PerlIO_printf(Perl_debug_log,"REG_TOP_LEVEL_BRANCHES_SEEN ");    \
919                                                                             \
920             if (RExC_seen & REG_VERBARG_SEEN)                               \
921                 PerlIO_printf(Perl_debug_log,"REG_VERBARG_SEEN ");          \
922                                                                             \
923             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
924                 PerlIO_printf(Perl_debug_log,"REG_CUTGROUP_SEEN ");         \
925                                                                             \
926             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
927                 PerlIO_printf(Perl_debug_log,"REG_RUN_ON_COMMENT_SEEN ");   \
928                                                                             \
929             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
930                 PerlIO_printf(Perl_debug_log,"REG_UNFOLDED_MULTI_SEEN ");   \
931                                                                             \
932             if (RExC_seen & REG_GOSTART_SEEN)                               \
933                 PerlIO_printf(Perl_debug_log,"REG_GOSTART_SEEN ");          \
934                                                                             \
935             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                               \
936                 PerlIO_printf(Perl_debug_log,"REG_UNBOUNDED_QUANTIFIER_SEEN ");          \
937                                                                             \
938             PerlIO_printf(Perl_debug_log,"\n");                             \
939         });
940
941 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
942   if ((flags) & flag) PerlIO_printf(Perl_debug_log, "%s ", #flag)
943
944 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
945     if ( ( flags ) ) {                                                      \
946         PerlIO_printf(Perl_debug_log, "%s", open_str);                      \
947         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
948         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
949         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
950         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
951         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
952         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
953         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
954         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
955         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
956         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
957         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
958         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
959         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
960         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
961         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
962         PerlIO_printf(Perl_debug_log, "%s", close_str);                     \
963     }
964
965
966 #define DEBUG_STUDYDATA(str,data,depth)                              \
967 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
968     PerlIO_printf(Perl_debug_log,                                    \
969         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
970         " Flags: 0x%"UVXf,                                           \
971         (int)(depth)*2, "",                                          \
972         (IV)((data)->pos_min),                                       \
973         (IV)((data)->pos_delta),                                     \
974         (UV)((data)->flags)                                          \
975     );                                                               \
976     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
977     PerlIO_printf(Perl_debug_log,                                    \
978         " Whilem_c: %"IVdf" Lcp: %"IVdf" %s",                        \
979         (IV)((data)->whilem_c),                                      \
980         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
981         is_inf ? "INF " : ""                                         \
982     );                                                               \
983     if ((data)->last_found)                                          \
984         PerlIO_printf(Perl_debug_log,                                \
985             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
986             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
987             SvPVX_const((data)->last_found),                         \
988             (IV)((data)->last_end),                                  \
989             (IV)((data)->last_start_min),                            \
990             (IV)((data)->last_start_max),                            \
991             ((data)->longest &&                                      \
992              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
993             SvPVX_const((data)->longest_fixed),                      \
994             (IV)((data)->offset_fixed),                              \
995             ((data)->longest &&                                      \
996              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
997             SvPVX_const((data)->longest_float),                      \
998             (IV)((data)->offset_float_min),                          \
999             (IV)((data)->offset_float_max)                           \
1000         );                                                           \
1001     PerlIO_printf(Perl_debug_log,"\n");                              \
1002 });
1003
1004 /* =========================================================
1005  * BEGIN edit_distance stuff.
1006  *
1007  * This calculates how many single character changes of any type are needed to
1008  * transform a string into another one.  It is taken from version 3.1 of
1009  *
1010  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1011  */
1012
1013 /* Our unsorted dictionary linked list.   */
1014 /* Note we use UVs, not chars. */
1015
1016 struct dictionary{
1017   UV key;
1018   UV value;
1019   struct dictionary* next;
1020 };
1021 typedef struct dictionary item;
1022
1023
1024 PERL_STATIC_INLINE item*
1025 push(UV key,item* curr)
1026 {
1027     item* head;
1028     Newxz(head, 1, item);
1029     head->key = key;
1030     head->value = 0;
1031     head->next = curr;
1032     return head;
1033 }
1034
1035
1036 PERL_STATIC_INLINE item*
1037 find(item* head, UV key)
1038 {
1039     item* iterator = head;
1040     while (iterator){
1041         if (iterator->key == key){
1042             return iterator;
1043         }
1044         iterator = iterator->next;
1045     }
1046
1047     return NULL;
1048 }
1049
1050 PERL_STATIC_INLINE item*
1051 uniquePush(item* head,UV key)
1052 {
1053     item* iterator = head;
1054
1055     while (iterator){
1056         if (iterator->key == key) {
1057             return head;
1058         }
1059         iterator = iterator->next;
1060     }
1061
1062     return push(key,head);
1063 }
1064
1065 PERL_STATIC_INLINE void
1066 dict_free(item* head)
1067 {
1068     item* iterator = head;
1069
1070     while (iterator) {
1071         item* temp = iterator;
1072         iterator = iterator->next;
1073         Safefree(temp);
1074     }
1075
1076     head = NULL;
1077 }
1078
1079 /* End of Dictionary Stuff */
1080
1081 /* All calculations/work are done here */
1082 STATIC int
1083 S_edit_distance(const UV* src,
1084                 const UV* tgt,
1085                 const STRLEN x,             /* length of src[] */
1086                 const STRLEN y,             /* length of tgt[] */
1087                 const SSize_t maxDistance
1088 )
1089 {
1090     item *head = NULL;
1091     UV swapCount,swapScore,targetCharCount,i,j;
1092     UV *scores;
1093     UV score_ceil = x + y;
1094
1095     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1096
1097     /* intialize matrix start values */
1098     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1099     scores[0] = score_ceil;
1100     scores[1 * (y + 2) + 0] = score_ceil;
1101     scores[0 * (y + 2) + 1] = score_ceil;
1102     scores[1 * (y + 2) + 1] = 0;
1103     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1104
1105     /* work loops    */
1106     /* i = src index */
1107     /* j = tgt index */
1108     for (i=1;i<=x;i++) {
1109         if (i < x)
1110             head = uniquePush(head,src[i]);
1111         scores[(i+1) * (y + 2) + 1] = i;
1112         scores[(i+1) * (y + 2) + 0] = score_ceil;
1113         swapCount = 0;
1114
1115         for (j=1;j<=y;j++) {
1116             if (i == 1) {
1117                 if(j < y)
1118                 head = uniquePush(head,tgt[j]);
1119                 scores[1 * (y + 2) + (j + 1)] = j;
1120                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1121             }
1122
1123             targetCharCount = find(head,tgt[j-1])->value;
1124             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1125
1126             if (src[i-1] != tgt[j-1]){
1127                 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));
1128             }
1129             else {
1130                 swapCount = j;
1131                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1132             }
1133         }
1134
1135         find(head,src[i-1])->value = i;
1136     }
1137
1138     {
1139         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1140         dict_free(head);
1141         Safefree(scores);
1142         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1143     }
1144 }
1145
1146 /* END of edit_distance() stuff
1147  * ========================================================= */
1148
1149 /* is c a control character for which we have a mnemonic? */
1150 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1151
1152 STATIC const char *
1153 S_cntrl_to_mnemonic(const U8 c)
1154 {
1155     /* Returns the mnemonic string that represents character 'c', if one
1156      * exists; NULL otherwise.  The only ones that exist for the purposes of
1157      * this routine are a few control characters */
1158
1159     switch (c) {
1160         case '\a':       return "\\a";
1161         case '\b':       return "\\b";
1162         case ESC_NATIVE: return "\\e";
1163         case '\f':       return "\\f";
1164         case '\n':       return "\\n";
1165         case '\r':       return "\\r";
1166         case '\t':       return "\\t";
1167     }
1168
1169     return NULL;
1170 }
1171
1172 /* Mark that we cannot extend a found fixed substring at this point.
1173    Update the longest found anchored substring and the longest found
1174    floating substrings if needed. */
1175
1176 STATIC void
1177 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1178                     SSize_t *minlenp, int is_inf)
1179 {
1180     const STRLEN l = CHR_SVLEN(data->last_found);
1181     const STRLEN old_l = CHR_SVLEN(*data->longest);
1182     GET_RE_DEBUG_FLAGS_DECL;
1183
1184     PERL_ARGS_ASSERT_SCAN_COMMIT;
1185
1186     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1187         SvSetMagicSV(*data->longest, data->last_found);
1188         if (*data->longest == data->longest_fixed) {
1189             data->offset_fixed = l ? data->last_start_min : data->pos_min;
1190             if (data->flags & SF_BEFORE_EOL)
1191                 data->flags
1192                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
1193             else
1194                 data->flags &= ~SF_FIX_BEFORE_EOL;
1195             data->minlen_fixed=minlenp;
1196             data->lookbehind_fixed=0;
1197         }
1198         else { /* *data->longest == data->longest_float */
1199             data->offset_float_min = l ? data->last_start_min : data->pos_min;
1200             data->offset_float_max = (l
1201                           ? data->last_start_max
1202                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1203                                          ? SSize_t_MAX
1204                                          : data->pos_min + data->pos_delta));
1205             if (is_inf
1206                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
1207                 data->offset_float_max = SSize_t_MAX;
1208             if (data->flags & SF_BEFORE_EOL)
1209                 data->flags
1210                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
1211             else
1212                 data->flags &= ~SF_FL_BEFORE_EOL;
1213             data->minlen_float=minlenp;
1214             data->lookbehind_float=0;
1215         }
1216     }
1217     SvCUR_set(data->last_found, 0);
1218     {
1219         SV * const sv = data->last_found;
1220         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1221             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1222             if (mg)
1223                 mg->mg_len = 0;
1224         }
1225     }
1226     data->last_end = -1;
1227     data->flags &= ~SF_BEFORE_EOL;
1228     DEBUG_STUDYDATA("commit: ",data,0);
1229 }
1230
1231 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1232  * list that describes which code points it matches */
1233
1234 STATIC void
1235 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1236 {
1237     /* Set the SSC 'ssc' to match an empty string or any code point */
1238
1239     PERL_ARGS_ASSERT_SSC_ANYTHING;
1240
1241     assert(is_ANYOF_SYNTHETIC(ssc));
1242
1243     ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */
1244     _append_range_to_invlist(ssc->invlist, 0, UV_MAX);
1245     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1246 }
1247
1248 STATIC int
1249 S_ssc_is_anything(const regnode_ssc *ssc)
1250 {
1251     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1252      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1253      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1254      * in any way, so there's no point in using it */
1255
1256     UV start, end;
1257     bool ret;
1258
1259     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1260
1261     assert(is_ANYOF_SYNTHETIC(ssc));
1262
1263     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1264         return FALSE;
1265     }
1266
1267     /* See if the list consists solely of the range 0 - Infinity */
1268     invlist_iterinit(ssc->invlist);
1269     ret = invlist_iternext(ssc->invlist, &start, &end)
1270           && start == 0
1271           && end == UV_MAX;
1272
1273     invlist_iterfinish(ssc->invlist);
1274
1275     if (ret) {
1276         return TRUE;
1277     }
1278
1279     /* If e.g., both \w and \W are set, matches everything */
1280     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1281         int i;
1282         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1283             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1284                 return TRUE;
1285             }
1286         }
1287     }
1288
1289     return FALSE;
1290 }
1291
1292 STATIC void
1293 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1294 {
1295     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1296      * string, any code point, or any posix class under locale */
1297
1298     PERL_ARGS_ASSERT_SSC_INIT;
1299
1300     Zero(ssc, 1, regnode_ssc);
1301     set_ANYOF_SYNTHETIC(ssc);
1302     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1303     ssc_anything(ssc);
1304
1305     /* If any portion of the regex is to operate under locale rules that aren't
1306      * fully known at compile time, initialization includes it.  The reason
1307      * this isn't done for all regexes is that the optimizer was written under
1308      * the assumption that locale was all-or-nothing.  Given the complexity and
1309      * lack of documentation in the optimizer, and that there are inadequate
1310      * test cases for locale, many parts of it may not work properly, it is
1311      * safest to avoid locale unless necessary. */
1312     if (RExC_contains_locale) {
1313         ANYOF_POSIXL_SETALL(ssc);
1314     }
1315     else {
1316         ANYOF_POSIXL_ZERO(ssc);
1317     }
1318 }
1319
1320 STATIC int
1321 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1322                         const regnode_ssc *ssc)
1323 {
1324     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1325      * to the list of code points matched, and locale posix classes; hence does
1326      * not check its flags) */
1327
1328     UV start, end;
1329     bool ret;
1330
1331     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1332
1333     assert(is_ANYOF_SYNTHETIC(ssc));
1334
1335     invlist_iterinit(ssc->invlist);
1336     ret = invlist_iternext(ssc->invlist, &start, &end)
1337           && start == 0
1338           && end == UV_MAX;
1339
1340     invlist_iterfinish(ssc->invlist);
1341
1342     if (! ret) {
1343         return FALSE;
1344     }
1345
1346     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1347         return FALSE;
1348     }
1349
1350     return TRUE;
1351 }
1352
1353 STATIC SV*
1354 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1355                                const regnode_charclass* const node)
1356 {
1357     /* Returns a mortal inversion list defining which code points are matched
1358      * by 'node', which is of type ANYOF.  Handles complementing the result if
1359      * appropriate.  If some code points aren't knowable at this time, the
1360      * returned list must, and will, contain every code point that is a
1361      * possibility. */
1362
1363     SV* invlist = NULL;
1364     SV* only_utf8_locale_invlist = NULL;
1365     unsigned int i;
1366     const U32 n = ARG(node);
1367     bool new_node_has_latin1 = FALSE;
1368
1369     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1370
1371     /* Look at the data structure created by S_set_ANYOF_arg() */
1372     if (n != ANYOF_ONLY_HAS_BITMAP) {
1373         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1374         AV * const av = MUTABLE_AV(SvRV(rv));
1375         SV **const ary = AvARRAY(av);
1376         assert(RExC_rxi->data->what[n] == 's');
1377
1378         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1379             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1380         }
1381         else if (ary[0] && ary[0] != &PL_sv_undef) {
1382
1383             /* Here, no compile-time swash, and there are things that won't be
1384              * known until runtime -- we have to assume it could be anything */
1385             invlist = sv_2mortal(_new_invlist(1));
1386             return _add_range_to_invlist(invlist, 0, UV_MAX);
1387         }
1388         else if (ary[3] && ary[3] != &PL_sv_undef) {
1389
1390             /* Here no compile-time swash, and no run-time only data.  Use the
1391              * node's inversion list */
1392             invlist = sv_2mortal(invlist_clone(ary[3]));
1393         }
1394
1395         /* Get the code points valid only under UTF-8 locales */
1396         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1397             && ary[2] && ary[2] != &PL_sv_undef)
1398         {
1399             only_utf8_locale_invlist = ary[2];
1400         }
1401     }
1402
1403     if (! invlist) {
1404         invlist = sv_2mortal(_new_invlist(0));
1405     }
1406
1407     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1408      * code points, and an inversion list for the others, but if there are code
1409      * points that should match only conditionally on the target string being
1410      * UTF-8, those are placed in the inversion list, and not the bitmap.
1411      * Since there are circumstances under which they could match, they are
1412      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1413      * to exclude them here, so that when we invert below, the end result
1414      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1415      * have to do this here before we add the unconditionally matched code
1416      * points */
1417     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1418         _invlist_intersection_complement_2nd(invlist,
1419                                              PL_UpperLatin1,
1420                                              &invlist);
1421     }
1422
1423     /* Add in the points from the bit map */
1424     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1425         if (ANYOF_BITMAP_TEST(node, i)) {
1426             invlist = add_cp_to_invlist(invlist, i);
1427             new_node_has_latin1 = TRUE;
1428         }
1429     }
1430
1431     /* If this can match all upper Latin1 code points, have to add them
1432      * as well.  But don't add them if inverting, as when that gets done below,
1433      * it would exclude all these characters, including the ones it shouldn't
1434      * that were added just above */
1435     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1436         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1437     {
1438         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1439     }
1440
1441     /* Similarly for these */
1442     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1443         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1444     }
1445
1446     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1447         _invlist_invert(invlist);
1448     }
1449     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1450
1451         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1452          * locale.  We can skip this if there are no 0-255 at all. */
1453         _invlist_union(invlist, PL_Latin1, &invlist);
1454     }
1455
1456     /* Similarly add the UTF-8 locale possible matches.  These have to be
1457      * deferred until after the non-UTF-8 locale ones are taken care of just
1458      * above, or it leads to wrong results under ANYOF_INVERT */
1459     if (only_utf8_locale_invlist) {
1460         _invlist_union_maybe_complement_2nd(invlist,
1461                                             only_utf8_locale_invlist,
1462                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1463                                             &invlist);
1464     }
1465
1466     return invlist;
1467 }
1468
1469 /* These two functions currently do the exact same thing */
1470 #define ssc_init_zero           ssc_init
1471
1472 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1473 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1474
1475 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1476  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1477  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1478
1479 STATIC void
1480 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1481                 const regnode_charclass *and_with)
1482 {
1483     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1484      * another SSC or a regular ANYOF class.  Can create false positives. */
1485
1486     SV* anded_cp_list;
1487     U8  anded_flags;
1488
1489     PERL_ARGS_ASSERT_SSC_AND;
1490
1491     assert(is_ANYOF_SYNTHETIC(ssc));
1492
1493     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1494      * the code point inversion list and just the relevant flags */
1495     if (is_ANYOF_SYNTHETIC(and_with)) {
1496         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1497         anded_flags = ANYOF_FLAGS(and_with);
1498
1499         /* XXX This is a kludge around what appears to be deficiencies in the
1500          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1501          * there are paths through the optimizer where it doesn't get weeded
1502          * out when it should.  And if we don't make some extra provision for
1503          * it like the code just below, it doesn't get added when it should.
1504          * This solution is to add it only when AND'ing, which is here, and
1505          * only when what is being AND'ed is the pristine, original node
1506          * matching anything.  Thus it is like adding it to ssc_anything() but
1507          * only when the result is to be AND'ed.  Probably the same solution
1508          * could be adopted for the same problem we have with /l matching,
1509          * which is solved differently in S_ssc_init(), and that would lead to
1510          * fewer false positives than that solution has.  But if this solution
1511          * creates bugs, the consequences are only that a warning isn't raised
1512          * that should be; while the consequences for having /l bugs is
1513          * incorrect matches */
1514         if (ssc_is_anything((regnode_ssc *)and_with)) {
1515             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1516         }
1517     }
1518     else {
1519         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1520         if (OP(and_with) == ANYOFD) {
1521             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1522         }
1523         else {
1524             anded_flags = ANYOF_FLAGS(and_with)
1525             &( ANYOF_COMMON_FLAGS
1526               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1527               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1528             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1529                 anded_flags &=
1530                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1531             }
1532         }
1533     }
1534
1535     ANYOF_FLAGS(ssc) &= anded_flags;
1536
1537     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1538      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1539      * 'and_with' may be inverted.  When not inverted, we have the situation of
1540      * computing:
1541      *  (C1 | P1) & (C2 | P2)
1542      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1543      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1544      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1545      *                    <=  ((C1 & C2) | P1 | P2)
1546      * Alternatively, the last few steps could be:
1547      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1548      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1549      *                    <=  (C1 | C2 | (P1 & P2))
1550      * We favor the second approach if either P1 or P2 is non-empty.  This is
1551      * because these components are a barrier to doing optimizations, as what
1552      * they match cannot be known until the moment of matching as they are
1553      * dependent on the current locale, 'AND"ing them likely will reduce or
1554      * eliminate them.
1555      * But we can do better if we know that C1,P1 are in their initial state (a
1556      * frequent occurrence), each matching everything:
1557      *  (<everything>) & (C2 | P2) =  C2 | P2
1558      * Similarly, if C2,P2 are in their initial state (again a frequent
1559      * occurrence), the result is a no-op
1560      *  (C1 | P1) & (<everything>) =  C1 | P1
1561      *
1562      * Inverted, we have
1563      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1564      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1565      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1566      * */
1567
1568     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1569         && ! is_ANYOF_SYNTHETIC(and_with))
1570     {
1571         unsigned int i;
1572
1573         ssc_intersection(ssc,
1574                          anded_cp_list,
1575                          FALSE /* Has already been inverted */
1576                          );
1577
1578         /* If either P1 or P2 is empty, the intersection will be also; can skip
1579          * the loop */
1580         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1581             ANYOF_POSIXL_ZERO(ssc);
1582         }
1583         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1584
1585             /* Note that the Posix class component P from 'and_with' actually
1586              * looks like:
1587              *      P = Pa | Pb | ... | Pn
1588              * where each component is one posix class, such as in [\w\s].
1589              * Thus
1590              *      ~P = ~(Pa | Pb | ... | Pn)
1591              *         = ~Pa & ~Pb & ... & ~Pn
1592              *        <= ~Pa | ~Pb | ... | ~Pn
1593              * The last is something we can easily calculate, but unfortunately
1594              * is likely to have many false positives.  We could do better
1595              * in some (but certainly not all) instances if two classes in
1596              * P have known relationships.  For example
1597              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1598              * So
1599              *      :lower: & :print: = :lower:
1600              * And similarly for classes that must be disjoint.  For example,
1601              * since \s and \w can have no elements in common based on rules in
1602              * the POSIX standard,
1603              *      \w & ^\S = nothing
1604              * Unfortunately, some vendor locales do not meet the Posix
1605              * standard, in particular almost everything by Microsoft.
1606              * The loop below just changes e.g., \w into \W and vice versa */
1607
1608             regnode_charclass_posixl temp;
1609             int add = 1;    /* To calculate the index of the complement */
1610
1611             ANYOF_POSIXL_ZERO(&temp);
1612             for (i = 0; i < ANYOF_MAX; i++) {
1613                 assert(i % 2 != 0
1614                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1615                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1616
1617                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1618                     ANYOF_POSIXL_SET(&temp, i + add);
1619                 }
1620                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1621             }
1622             ANYOF_POSIXL_AND(&temp, ssc);
1623
1624         } /* else ssc already has no posixes */
1625     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1626          in its initial state */
1627     else if (! is_ANYOF_SYNTHETIC(and_with)
1628              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1629     {
1630         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1631          * copy it over 'ssc' */
1632         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1633             if (is_ANYOF_SYNTHETIC(and_with)) {
1634                 StructCopy(and_with, ssc, regnode_ssc);
1635             }
1636             else {
1637                 ssc->invlist = anded_cp_list;
1638                 ANYOF_POSIXL_ZERO(ssc);
1639                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1640                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1641                 }
1642             }
1643         }
1644         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1645                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1646         {
1647             /* One or the other of P1, P2 is non-empty. */
1648             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1649                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1650             }
1651             ssc_union(ssc, anded_cp_list, FALSE);
1652         }
1653         else { /* P1 = P2 = empty */
1654             ssc_intersection(ssc, anded_cp_list, FALSE);
1655         }
1656     }
1657 }
1658
1659 STATIC void
1660 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1661                const regnode_charclass *or_with)
1662 {
1663     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1664      * another SSC or a regular ANYOF class.  Can create false positives if
1665      * 'or_with' is to be inverted. */
1666
1667     SV* ored_cp_list;
1668     U8 ored_flags;
1669
1670     PERL_ARGS_ASSERT_SSC_OR;
1671
1672     assert(is_ANYOF_SYNTHETIC(ssc));
1673
1674     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1675      * the code point inversion list and just the relevant flags */
1676     if (is_ANYOF_SYNTHETIC(or_with)) {
1677         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1678         ored_flags = ANYOF_FLAGS(or_with);
1679     }
1680     else {
1681         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1682         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1683         if (OP(or_with) != ANYOFD) {
1684             ored_flags
1685             |= ANYOF_FLAGS(or_with)
1686              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1687                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1688             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1689                 ored_flags |=
1690                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1691             }
1692         }
1693     }
1694
1695     ANYOF_FLAGS(ssc) |= ored_flags;
1696
1697     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1698      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1699      * 'or_with' may be inverted.  When not inverted, we have the simple
1700      * situation of computing:
1701      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1702      * If P1|P2 yields a situation with both a class and its complement are
1703      * set, like having both \w and \W, this matches all code points, and we
1704      * can delete these from the P component of the ssc going forward.  XXX We
1705      * might be able to delete all the P components, but I (khw) am not certain
1706      * about this, and it is better to be safe.
1707      *
1708      * Inverted, we have
1709      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1710      *                         <=  (C1 | P1) | ~C2
1711      *                         <=  (C1 | ~C2) | P1
1712      * (which results in actually simpler code than the non-inverted case)
1713      * */
1714
1715     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1716         && ! is_ANYOF_SYNTHETIC(or_with))
1717     {
1718         /* We ignore P2, leaving P1 going forward */
1719     }   /* else  Not inverted */
1720     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1721         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1722         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1723             unsigned int i;
1724             for (i = 0; i < ANYOF_MAX; i += 2) {
1725                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1726                 {
1727                     ssc_match_all_cp(ssc);
1728                     ANYOF_POSIXL_CLEAR(ssc, i);
1729                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1730                 }
1731             }
1732         }
1733     }
1734
1735     ssc_union(ssc,
1736               ored_cp_list,
1737               FALSE /* Already has been inverted */
1738               );
1739 }
1740
1741 PERL_STATIC_INLINE void
1742 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1743 {
1744     PERL_ARGS_ASSERT_SSC_UNION;
1745
1746     assert(is_ANYOF_SYNTHETIC(ssc));
1747
1748     _invlist_union_maybe_complement_2nd(ssc->invlist,
1749                                         invlist,
1750                                         invert2nd,
1751                                         &ssc->invlist);
1752 }
1753
1754 PERL_STATIC_INLINE void
1755 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1756                          SV* const invlist,
1757                          const bool invert2nd)
1758 {
1759     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1760
1761     assert(is_ANYOF_SYNTHETIC(ssc));
1762
1763     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1764                                                invlist,
1765                                                invert2nd,
1766                                                &ssc->invlist);
1767 }
1768
1769 PERL_STATIC_INLINE void
1770 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1771 {
1772     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1773
1774     assert(is_ANYOF_SYNTHETIC(ssc));
1775
1776     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1777 }
1778
1779 PERL_STATIC_INLINE void
1780 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1781 {
1782     /* AND just the single code point 'cp' into the SSC 'ssc' */
1783
1784     SV* cp_list = _new_invlist(2);
1785
1786     PERL_ARGS_ASSERT_SSC_CP_AND;
1787
1788     assert(is_ANYOF_SYNTHETIC(ssc));
1789
1790     cp_list = add_cp_to_invlist(cp_list, cp);
1791     ssc_intersection(ssc, cp_list,
1792                      FALSE /* Not inverted */
1793                      );
1794     SvREFCNT_dec_NN(cp_list);
1795 }
1796
1797 PERL_STATIC_INLINE void
1798 S_ssc_clear_locale(regnode_ssc *ssc)
1799 {
1800     /* Set the SSC 'ssc' to not match any locale things */
1801     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1802
1803     assert(is_ANYOF_SYNTHETIC(ssc));
1804
1805     ANYOF_POSIXL_ZERO(ssc);
1806     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1807 }
1808
1809 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1810
1811 STATIC bool
1812 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1813 {
1814     /* The synthetic start class is used to hopefully quickly winnow down
1815      * places where a pattern could start a match in the target string.  If it
1816      * doesn't really narrow things down that much, there isn't much point to
1817      * having the overhead of using it.  This function uses some very crude
1818      * heuristics to decide if to use the ssc or not.
1819      *
1820      * It returns TRUE if 'ssc' rules out more than half what it considers to
1821      * be the "likely" possible matches, but of course it doesn't know what the
1822      * actual things being matched are going to be; these are only guesses
1823      *
1824      * For /l matches, it assumes that the only likely matches are going to be
1825      *      in the 0-255 range, uniformly distributed, so half of that is 127
1826      * For /a and /d matches, it assumes that the likely matches will be just
1827      *      the ASCII range, so half of that is 63
1828      * For /u and there isn't anything matching above the Latin1 range, it
1829      *      assumes that that is the only range likely to be matched, and uses
1830      *      half that as the cut-off: 127.  If anything matches above Latin1,
1831      *      it assumes that all of Unicode could match (uniformly), except for
1832      *      non-Unicode code points and things in the General Category "Other"
1833      *      (unassigned, private use, surrogates, controls and formats).  This
1834      *      is a much large number. */
1835
1836     U32 count = 0;      /* Running total of number of code points matched by
1837                            'ssc' */
1838     UV start, end;      /* Start and end points of current range in inversion
1839                            list */
1840     const U32 max_code_points = (LOC)
1841                                 ?  256
1842                                 : ((   ! UNI_SEMANTICS
1843                                      || invlist_highest(ssc->invlist) < 256)
1844                                   ? 128
1845                                   : NON_OTHER_COUNT);
1846     const U32 max_match = max_code_points / 2;
1847
1848     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1849
1850     invlist_iterinit(ssc->invlist);
1851     while (invlist_iternext(ssc->invlist, &start, &end)) {
1852         if (start >= max_code_points) {
1853             break;
1854         }
1855         end = MIN(end, max_code_points - 1);
1856         count += end - start + 1;
1857         if (count >= max_match) {
1858             invlist_iterfinish(ssc->invlist);
1859             return FALSE;
1860         }
1861     }
1862
1863     return TRUE;
1864 }
1865
1866
1867 STATIC void
1868 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1869 {
1870     /* The inversion list in the SSC is marked mortal; now we need a more
1871      * permanent copy, which is stored the same way that is done in a regular
1872      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1873      * map */
1874
1875     SV* invlist = invlist_clone(ssc->invlist);
1876
1877     PERL_ARGS_ASSERT_SSC_FINALIZE;
1878
1879     assert(is_ANYOF_SYNTHETIC(ssc));
1880
1881     /* The code in this file assumes that all but these flags aren't relevant
1882      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1883      * by the time we reach here */
1884     assert(! (ANYOF_FLAGS(ssc)
1885         & ~( ANYOF_COMMON_FLAGS
1886             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1887             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
1888
1889     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1890
1891     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1892                                 NULL, NULL, NULL, FALSE);
1893
1894     /* Make sure is clone-safe */
1895     ssc->invlist = NULL;
1896
1897     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1898         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1899     }
1900
1901     if (RExC_contains_locale) {
1902         OP(ssc) = ANYOFL;
1903     }
1904
1905     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1906 }
1907
1908 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1909 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1910 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1911 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1912                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1913                                : 0 )
1914
1915
1916 #ifdef DEBUGGING
1917 /*
1918    dump_trie(trie,widecharmap,revcharmap)
1919    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1920    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1921
1922    These routines dump out a trie in a somewhat readable format.
1923    The _interim_ variants are used for debugging the interim
1924    tables that are used to generate the final compressed
1925    representation which is what dump_trie expects.
1926
1927    Part of the reason for their existence is to provide a form
1928    of documentation as to how the different representations function.
1929
1930 */
1931
1932 /*
1933   Dumps the final compressed table form of the trie to Perl_debug_log.
1934   Used for debugging make_trie().
1935 */
1936
1937 STATIC void
1938 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1939             AV *revcharmap, U32 depth)
1940 {
1941     U32 state;
1942     SV *sv=sv_newmortal();
1943     int colwidth= widecharmap ? 6 : 4;
1944     U16 word;
1945     GET_RE_DEBUG_FLAGS_DECL;
1946
1947     PERL_ARGS_ASSERT_DUMP_TRIE;
1948
1949     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1950         (int)depth * 2 + 2,"",
1951         "Match","Base","Ofs" );
1952
1953     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1954         SV ** const tmp = av_fetch( revcharmap, state, 0);
1955         if ( tmp ) {
1956             PerlIO_printf( Perl_debug_log, "%*s",
1957                 colwidth,
1958                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1959                             PL_colors[0], PL_colors[1],
1960                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1961                             PERL_PV_ESCAPE_FIRSTCHAR
1962                 )
1963             );
1964         }
1965     }
1966     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1967         (int)depth * 2 + 2,"");
1968
1969     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1970         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1971     PerlIO_printf( Perl_debug_log, "\n");
1972
1973     for( state = 1 ; state < trie->statecount ; state++ ) {
1974         const U32 base = trie->states[ state ].trans.base;
1975
1976         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|",
1977                                        (int)depth * 2 + 2,"", (UV)state);
1978
1979         if ( trie->states[ state ].wordnum ) {
1980             PerlIO_printf( Perl_debug_log, " W%4X",
1981                                            trie->states[ state ].wordnum );
1982         } else {
1983             PerlIO_printf( Perl_debug_log, "%6s", "" );
1984         }
1985
1986         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1987
1988         if ( base ) {
1989             U32 ofs = 0;
1990
1991             while( ( base + ofs  < trie->uniquecharcount ) ||
1992                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1993                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
1994                                                                     != state))
1995                     ofs++;
1996
1997             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1998
1999             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2000                 if ( ( base + ofs >= trie->uniquecharcount )
2001                         && ( base + ofs - trie->uniquecharcount
2002                                                         < trie->lasttrans )
2003                         && trie->trans[ base + ofs
2004                                     - trie->uniquecharcount ].check == state )
2005                 {
2006                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
2007                     colwidth,
2008                     (UV)trie->trans[ base + ofs
2009                                              - trie->uniquecharcount ].next );
2010                 } else {
2011                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
2012                 }
2013             }
2014
2015             PerlIO_printf( Perl_debug_log, "]");
2016
2017         }
2018         PerlIO_printf( Perl_debug_log, "\n" );
2019     }
2020     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=",
2021                                 (int)depth*2, "");
2022     for (word=1; word <= trie->wordcount; word++) {
2023         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
2024             (int)word, (int)(trie->wordinfo[word].prev),
2025             (int)(trie->wordinfo[word].len));
2026     }
2027     PerlIO_printf(Perl_debug_log, "\n" );
2028 }
2029 /*
2030   Dumps a fully constructed but uncompressed trie in list form.
2031   List tries normally only are used for construction when the number of
2032   possible chars (trie->uniquecharcount) is very high.
2033   Used for debugging make_trie().
2034 */
2035 STATIC void
2036 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2037                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2038                          U32 depth)
2039 {
2040     U32 state;
2041     SV *sv=sv_newmortal();
2042     int colwidth= widecharmap ? 6 : 4;
2043     GET_RE_DEBUG_FLAGS_DECL;
2044
2045     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2046
2047     /* print out the table precompression.  */
2048     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
2049         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
2050         "------:-----+-----------------\n" );
2051
2052     for( state=1 ; state < next_alloc ; state ++ ) {
2053         U16 charid;
2054
2055         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
2056             (int)depth * 2 + 2,"", (UV)state  );
2057         if ( ! trie->states[ state ].wordnum ) {
2058             PerlIO_printf( Perl_debug_log, "%5s| ","");
2059         } else {
2060             PerlIO_printf( Perl_debug_log, "W%4x| ",
2061                 trie->states[ state ].wordnum
2062             );
2063         }
2064         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2065             SV ** const tmp = av_fetch( revcharmap,
2066                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2067             if ( tmp ) {
2068                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
2069                     colwidth,
2070                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2071                               colwidth,
2072                               PL_colors[0], PL_colors[1],
2073                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2074                               | PERL_PV_ESCAPE_FIRSTCHAR
2075                     ) ,
2076                     TRIE_LIST_ITEM(state,charid).forid,
2077                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2078                 );
2079                 if (!(charid % 10))
2080                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
2081                         (int)((depth * 2) + 14), "");
2082             }
2083         }
2084         PerlIO_printf( Perl_debug_log, "\n");
2085     }
2086 }
2087
2088 /*
2089   Dumps a fully constructed but uncompressed trie in table form.
2090   This is the normal DFA style state transition table, with a few
2091   twists to facilitate compression later.
2092   Used for debugging make_trie().
2093 */
2094 STATIC void
2095 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2096                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2097                           U32 depth)
2098 {
2099     U32 state;
2100     U16 charid;
2101     SV *sv=sv_newmortal();
2102     int colwidth= widecharmap ? 6 : 4;
2103     GET_RE_DEBUG_FLAGS_DECL;
2104
2105     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2106
2107     /*
2108        print out the table precompression so that we can do a visual check
2109        that they are identical.
2110      */
2111
2112     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
2113
2114     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2115         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2116         if ( tmp ) {
2117             PerlIO_printf( Perl_debug_log, "%*s",
2118                 colwidth,
2119                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2120                             PL_colors[0], PL_colors[1],
2121                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2122                             PERL_PV_ESCAPE_FIRSTCHAR
2123                 )
2124             );
2125         }
2126     }
2127
2128     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
2129
2130     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2131         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
2132     }
2133
2134     PerlIO_printf( Perl_debug_log, "\n" );
2135
2136     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2137
2138         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
2139             (int)depth * 2 + 2,"",
2140             (UV)TRIE_NODENUM( state ) );
2141
2142         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2143             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2144             if (v)
2145                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
2146             else
2147                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
2148         }
2149         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2150             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n",
2151                                             (UV)trie->trans[ state ].check );
2152         } else {
2153             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n",
2154                                             (UV)trie->trans[ state ].check,
2155             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2156         }
2157     }
2158 }
2159
2160 #endif
2161
2162
2163 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2164   startbranch: the first branch in the whole branch sequence
2165   first      : start branch of sequence of branch-exact nodes.
2166                May be the same as startbranch
2167   last       : Thing following the last branch.
2168                May be the same as tail.
2169   tail       : item following the branch sequence
2170   count      : words in the sequence
2171   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2172   depth      : indent depth
2173
2174 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2175
2176 A trie is an N'ary tree where the branches are determined by digital
2177 decomposition of the key. IE, at the root node you look up the 1st character and
2178 follow that branch repeat until you find the end of the branches. Nodes can be
2179 marked as "accepting" meaning they represent a complete word. Eg:
2180
2181   /he|she|his|hers/
2182
2183 would convert into the following structure. Numbers represent states, letters
2184 following numbers represent valid transitions on the letter from that state, if
2185 the number is in square brackets it represents an accepting state, otherwise it
2186 will be in parenthesis.
2187
2188       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2189       |    |
2190       |   (2)
2191       |    |
2192      (1)   +-i->(6)-+-s->[7]
2193       |
2194       +-s->(3)-+-h->(4)-+-e->[5]
2195
2196       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2197
2198 This shows that when matching against the string 'hers' we will begin at state 1
2199 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2200 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2201 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2202 single traverse. We store a mapping from accepting to state to which word was
2203 matched, and then when we have multiple possibilities we try to complete the
2204 rest of the regex in the order in which they occurred in the alternation.
2205
2206 The only prior NFA like behaviour that would be changed by the TRIE support is
2207 the silent ignoring of duplicate alternations which are of the form:
2208
2209  / (DUPE|DUPE) X? (?{ ... }) Y /x
2210
2211 Thus EVAL blocks following a trie may be called a different number of times with
2212 and without the optimisation. With the optimisations dupes will be silently
2213 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2214 the following demonstrates:
2215
2216  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2217
2218 which prints out 'word' three times, but
2219
2220  'words'=~/(word|word|word)(?{ print $1 })S/
2221
2222 which doesnt print it out at all. This is due to other optimisations kicking in.
2223
2224 Example of what happens on a structural level:
2225
2226 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2227
2228    1: CURLYM[1] {1,32767}(18)
2229    5:   BRANCH(8)
2230    6:     EXACT <ac>(16)
2231    8:   BRANCH(11)
2232    9:     EXACT <ad>(16)
2233   11:   BRANCH(14)
2234   12:     EXACT <ab>(16)
2235   16:   SUCCEED(0)
2236   17:   NOTHING(18)
2237   18: END(0)
2238
2239 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2240 and should turn into:
2241
2242    1: CURLYM[1] {1,32767}(18)
2243    5:   TRIE(16)
2244         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2245           <ac>
2246           <ad>
2247           <ab>
2248   16:   SUCCEED(0)
2249   17:   NOTHING(18)
2250   18: END(0)
2251
2252 Cases where tail != last would be like /(?foo|bar)baz/:
2253
2254    1: BRANCH(4)
2255    2:   EXACT <foo>(8)
2256    4: BRANCH(7)
2257    5:   EXACT <bar>(8)
2258    7: TAIL(8)
2259    8: EXACT <baz>(10)
2260   10: END(0)
2261
2262 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2263 and would end up looking like:
2264
2265     1: TRIE(8)
2266       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2267         <foo>
2268         <bar>
2269    7: TAIL(8)
2270    8: EXACT <baz>(10)
2271   10: END(0)
2272
2273     d = uvchr_to_utf8_flags(d, uv, 0);
2274
2275 is the recommended Unicode-aware way of saying
2276
2277     *(d++) = uv;
2278 */
2279
2280 #define TRIE_STORE_REVCHAR(val)                                            \
2281     STMT_START {                                                           \
2282         if (UTF) {                                                         \
2283             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2284             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2285             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2286             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2287             SvPOK_on(zlopp);                                               \
2288             SvUTF8_on(zlopp);                                              \
2289             av_push(revcharmap, zlopp);                                    \
2290         } else {                                                           \
2291             char ooooff = (char)val;                                           \
2292             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2293         }                                                                  \
2294         } STMT_END
2295
2296 /* This gets the next character from the input, folding it if not already
2297  * folded. */
2298 #define TRIE_READ_CHAR STMT_START {                                           \
2299     wordlen++;                                                                \
2300     if ( UTF ) {                                                              \
2301         /* if it is UTF then it is either already folded, or does not need    \
2302          * folding */                                                         \
2303         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2304     }                                                                         \
2305     else if (folder == PL_fold_latin1) {                                      \
2306         /* This folder implies Unicode rules, which in the range expressible  \
2307          *  by not UTF is the lower case, with the two exceptions, one of     \
2308          *  which should have been taken care of before calling this */       \
2309         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2310         uvc = toLOWER_L1(*uc);                                                \
2311         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2312         len = 1;                                                              \
2313     } else {                                                                  \
2314         /* raw data, will be folded later if needed */                        \
2315         uvc = (U32)*uc;                                                       \
2316         len = 1;                                                              \
2317     }                                                                         \
2318 } STMT_END
2319
2320
2321
2322 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2323     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2324         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
2325         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2326     }                                                           \
2327     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2328     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2329     TRIE_LIST_CUR( state )++;                                   \
2330 } STMT_END
2331
2332 #define TRIE_LIST_NEW(state) STMT_START {                       \
2333     Newxz( trie->states[ state ].trans.list,               \
2334         4, reg_trie_trans_le );                                 \
2335      TRIE_LIST_CUR( state ) = 1;                                \
2336      TRIE_LIST_LEN( state ) = 4;                                \
2337 } STMT_END
2338
2339 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2340     U16 dupe= trie->states[ state ].wordnum;                    \
2341     regnode * const noper_next = regnext( noper );              \
2342                                                                 \
2343     DEBUG_r({                                                   \
2344         /* store the word for dumping */                        \
2345         SV* tmp;                                                \
2346         if (OP(noper) != NOTHING)                               \
2347             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2348         else                                                    \
2349             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2350         av_push( trie_words, tmp );                             \
2351     });                                                         \
2352                                                                 \
2353     curword++;                                                  \
2354     trie->wordinfo[curword].prev   = 0;                         \
2355     trie->wordinfo[curword].len    = wordlen;                   \
2356     trie->wordinfo[curword].accept = state;                     \
2357                                                                 \
2358     if ( noper_next < tail ) {                                  \
2359         if (!trie->jump)                                        \
2360             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2361                                                  sizeof(U16) ); \
2362         trie->jump[curword] = (U16)(noper_next - convert);      \
2363         if (!jumper)                                            \
2364             jumper = noper_next;                                \
2365         if (!nextbranch)                                        \
2366             nextbranch= regnext(cur);                           \
2367     }                                                           \
2368                                                                 \
2369     if ( dupe ) {                                               \
2370         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2371         /* chain, so that when the bits of chain are later    */\
2372         /* linked together, the dups appear in the chain      */\
2373         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2374         trie->wordinfo[dupe].prev = curword;                    \
2375     } else {                                                    \
2376         /* we haven't inserted this word yet.                */ \
2377         trie->states[ state ].wordnum = curword;                \
2378     }                                                           \
2379 } STMT_END
2380
2381
2382 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2383      ( ( base + charid >=  ucharcount                                   \
2384          && base + charid < ubound                                      \
2385          && state == trie->trans[ base - ucharcount + charid ].check    \
2386          && trie->trans[ base - ucharcount + charid ].next )            \
2387            ? trie->trans[ base - ucharcount + charid ].next             \
2388            : ( state==1 ? special : 0 )                                 \
2389       )
2390
2391 #define MADE_TRIE       1
2392 #define MADE_JUMP_TRIE  2
2393 #define MADE_EXACT_TRIE 4
2394
2395 STATIC I32
2396 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2397                   regnode *first, regnode *last, regnode *tail,
2398                   U32 word_count, U32 flags, U32 depth)
2399 {
2400     /* first pass, loop through and scan words */
2401     reg_trie_data *trie;
2402     HV *widecharmap = NULL;
2403     AV *revcharmap = newAV();
2404     regnode *cur;
2405     STRLEN len = 0;
2406     UV uvc = 0;
2407     U16 curword = 0;
2408     U32 next_alloc = 0;
2409     regnode *jumper = NULL;
2410     regnode *nextbranch = NULL;
2411     regnode *convert = NULL;
2412     U32 *prev_states; /* temp array mapping each state to previous one */
2413     /* we just use folder as a flag in utf8 */
2414     const U8 * folder = NULL;
2415
2416 #ifdef DEBUGGING
2417     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2418     AV *trie_words = NULL;
2419     /* along with revcharmap, this only used during construction but both are
2420      * useful during debugging so we store them in the struct when debugging.
2421      */
2422 #else
2423     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2424     STRLEN trie_charcount=0;
2425 #endif
2426     SV *re_trie_maxbuff;
2427     GET_RE_DEBUG_FLAGS_DECL;
2428
2429     PERL_ARGS_ASSERT_MAKE_TRIE;
2430 #ifndef DEBUGGING
2431     PERL_UNUSED_ARG(depth);
2432 #endif
2433
2434     switch (flags) {
2435         case EXACT: case EXACTL: break;
2436         case EXACTFA:
2437         case EXACTFU_SS:
2438         case EXACTFU:
2439         case EXACTFLU8: folder = PL_fold_latin1; break;
2440         case EXACTF:  folder = PL_fold; break;
2441         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2442     }
2443
2444     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2445     trie->refcount = 1;
2446     trie->startstate = 1;
2447     trie->wordcount = word_count;
2448     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2449     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2450     if (flags == EXACT || flags == EXACTL)
2451         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2452     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2453                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2454
2455     DEBUG_r({
2456         trie_words = newAV();
2457     });
2458
2459     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2460     assert(re_trie_maxbuff);
2461     if (!SvIOK(re_trie_maxbuff)) {
2462         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2463     }
2464     DEBUG_TRIE_COMPILE_r({
2465         PerlIO_printf( Perl_debug_log,
2466           "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2467           (int)depth * 2 + 2, "",
2468           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2469           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2470     });
2471
2472    /* Find the node we are going to overwrite */
2473     if ( first == startbranch && OP( last ) != BRANCH ) {
2474         /* whole branch chain */
2475         convert = first;
2476     } else {
2477         /* branch sub-chain */
2478         convert = NEXTOPER( first );
2479     }
2480
2481     /*  -- First loop and Setup --
2482
2483        We first traverse the branches and scan each word to determine if it
2484        contains widechars, and how many unique chars there are, this is
2485        important as we have to build a table with at least as many columns as we
2486        have unique chars.
2487
2488        We use an array of integers to represent the character codes 0..255
2489        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2490        the native representation of the character value as the key and IV's for
2491        the coded index.
2492
2493        *TODO* If we keep track of how many times each character is used we can
2494        remap the columns so that the table compression later on is more
2495        efficient in terms of memory by ensuring the most common value is in the
2496        middle and the least common are on the outside.  IMO this would be better
2497        than a most to least common mapping as theres a decent chance the most
2498        common letter will share a node with the least common, meaning the node
2499        will not be compressible. With a middle is most common approach the worst
2500        case is when we have the least common nodes twice.
2501
2502      */
2503
2504     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2505         regnode *noper = NEXTOPER( cur );
2506         const U8 *uc = (U8*)STRING( noper );
2507         const U8 *e  = uc + STR_LEN( noper );
2508         int foldlen = 0;
2509         U32 wordlen      = 0;         /* required init */
2510         STRLEN minchars = 0;
2511         STRLEN maxchars = 0;
2512         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2513                                                bitmap?*/
2514
2515         if (OP(noper) == NOTHING) {
2516             regnode *noper_next= regnext(noper);
2517             if (noper_next != tail && OP(noper_next) == flags) {
2518                 noper = noper_next;
2519                 uc= (U8*)STRING(noper);
2520                 e= uc + STR_LEN(noper);
2521                 trie->minlen= STR_LEN(noper);
2522             } else {
2523                 trie->minlen= 0;
2524                 continue;
2525             }
2526         }
2527
2528         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2529             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2530                                           regardless of encoding */
2531             if (OP( noper ) == EXACTFU_SS) {
2532                 /* false positives are ok, so just set this */
2533                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2534             }
2535         }
2536         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2537                                            branch */
2538             TRIE_CHARCOUNT(trie)++;
2539             TRIE_READ_CHAR;
2540
2541             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2542              * is in effect.  Under /i, this character can match itself, or
2543              * anything that folds to it.  If not under /i, it can match just
2544              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2545              * all fold to k, and all are single characters.   But some folds
2546              * expand to more than one character, so for example LATIN SMALL
2547              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2548              * the string beginning at 'uc' is 'ffi', it could be matched by
2549              * three characters, or just by the one ligature character. (It
2550              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2551              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2552              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2553              * match.)  The trie needs to know the minimum and maximum number
2554              * of characters that could match so that it can use size alone to
2555              * quickly reject many match attempts.  The max is simple: it is
2556              * the number of folded characters in this branch (since a fold is
2557              * never shorter than what folds to it. */
2558
2559             maxchars++;
2560
2561             /* And the min is equal to the max if not under /i (indicated by
2562              * 'folder' being NULL), or there are no multi-character folds.  If
2563              * there is a multi-character fold, the min is incremented just
2564              * once, for the character that folds to the sequence.  Each
2565              * character in the sequence needs to be added to the list below of
2566              * characters in the trie, but we count only the first towards the
2567              * min number of characters needed.  This is done through the
2568              * variable 'foldlen', which is returned by the macros that look
2569              * for these sequences as the number of bytes the sequence
2570              * occupies.  Each time through the loop, we decrement 'foldlen' by
2571              * how many bytes the current char occupies.  Only when it reaches
2572              * 0 do we increment 'minchars' or look for another multi-character
2573              * sequence. */
2574             if (folder == NULL) {
2575                 minchars++;
2576             }
2577             else if (foldlen > 0) {
2578                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2579             }
2580             else {
2581                 minchars++;
2582
2583                 /* See if *uc is the beginning of a multi-character fold.  If
2584                  * so, we decrement the length remaining to look at, to account
2585                  * for the current character this iteration.  (We can use 'uc'
2586                  * instead of the fold returned by TRIE_READ_CHAR because for
2587                  * non-UTF, the latin1_safe macro is smart enough to account
2588                  * for all the unfolded characters, and because for UTF, the
2589                  * string will already have been folded earlier in the
2590                  * compilation process */
2591                 if (UTF) {
2592                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2593                         foldlen -= UTF8SKIP(uc);
2594                     }
2595                 }
2596                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2597                     foldlen--;
2598                 }
2599             }
2600
2601             /* The current character (and any potential folds) should be added
2602              * to the possible matching characters for this position in this
2603              * branch */
2604             if ( uvc < 256 ) {
2605                 if ( folder ) {
2606                     U8 folded= folder[ (U8) uvc ];
2607                     if ( !trie->charmap[ folded ] ) {
2608                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2609                         TRIE_STORE_REVCHAR( folded );
2610                     }
2611                 }
2612                 if ( !trie->charmap[ uvc ] ) {
2613                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2614                     TRIE_STORE_REVCHAR( uvc );
2615                 }
2616                 if ( set_bit ) {
2617                     /* store the codepoint in the bitmap, and its folded
2618                      * equivalent. */
2619                     TRIE_BITMAP_SET(trie, uvc);
2620
2621                     /* store the folded codepoint */
2622                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
2623
2624                     if ( !UTF ) {
2625                         /* store first byte of utf8 representation of
2626                            variant codepoints */
2627                         if (! UVCHR_IS_INVARIANT(uvc)) {
2628                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
2629                         }
2630                     }
2631                     set_bit = 0; /* We've done our bit :-) */
2632                 }
2633             } else {
2634
2635                 /* XXX We could come up with the list of code points that fold
2636                  * to this using PL_utf8_foldclosures, except not for
2637                  * multi-char folds, as there may be multiple combinations
2638                  * there that could work, which needs to wait until runtime to
2639                  * resolve (The comment about LIGATURE FFI above is such an
2640                  * example */
2641
2642                 SV** svpp;
2643                 if ( !widecharmap )
2644                     widecharmap = newHV();
2645
2646                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2647
2648                 if ( !svpp )
2649                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
2650
2651                 if ( !SvTRUE( *svpp ) ) {
2652                     sv_setiv( *svpp, ++trie->uniquecharcount );
2653                     TRIE_STORE_REVCHAR(uvc);
2654                 }
2655             }
2656         } /* end loop through characters in this branch of the trie */
2657
2658         /* We take the min and max for this branch and combine to find the min
2659          * and max for all branches processed so far */
2660         if( cur == first ) {
2661             trie->minlen = minchars;
2662             trie->maxlen = maxchars;
2663         } else if (minchars < trie->minlen) {
2664             trie->minlen = minchars;
2665         } else if (maxchars > trie->maxlen) {
2666             trie->maxlen = maxchars;
2667         }
2668     } /* end first pass */
2669     DEBUG_TRIE_COMPILE_r(
2670         PerlIO_printf( Perl_debug_log,
2671                 "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2672                 (int)depth * 2 + 2,"",
2673                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2674                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2675                 (int)trie->minlen, (int)trie->maxlen )
2676     );
2677
2678     /*
2679         We now know what we are dealing with in terms of unique chars and
2680         string sizes so we can calculate how much memory a naive
2681         representation using a flat table  will take. If it's over a reasonable
2682         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2683         conservative but potentially much slower representation using an array
2684         of lists.
2685
2686         At the end we convert both representations into the same compressed
2687         form that will be used in regexec.c for matching with. The latter
2688         is a form that cannot be used to construct with but has memory
2689         properties similar to the list form and access properties similar
2690         to the table form making it both suitable for fast searches and
2691         small enough that its feasable to store for the duration of a program.
2692
2693         See the comment in the code where the compressed table is produced
2694         inplace from the flat tabe representation for an explanation of how
2695         the compression works.
2696
2697     */
2698
2699
2700     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2701     prev_states[1] = 0;
2702
2703     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2704                                                     > SvIV(re_trie_maxbuff) )
2705     {
2706         /*
2707             Second Pass -- Array Of Lists Representation
2708
2709             Each state will be represented by a list of charid:state records
2710             (reg_trie_trans_le) the first such element holds the CUR and LEN
2711             points of the allocated array. (See defines above).
2712
2713             We build the initial structure using the lists, and then convert
2714             it into the compressed table form which allows faster lookups
2715             (but cant be modified once converted).
2716         */
2717
2718         STRLEN transcount = 1;
2719
2720         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2721             "%*sCompiling trie using list compiler\n",
2722             (int)depth * 2 + 2, ""));
2723
2724         trie->states = (reg_trie_state *)
2725             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2726                                   sizeof(reg_trie_state) );
2727         TRIE_LIST_NEW(1);
2728         next_alloc = 2;
2729
2730         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2731
2732             regnode *noper   = NEXTOPER( cur );
2733             U8 *uc           = (U8*)STRING( noper );
2734             const U8 *e      = uc + STR_LEN( noper );
2735             U32 state        = 1;         /* required init */
2736             U16 charid       = 0;         /* sanity init */
2737             U32 wordlen      = 0;         /* required init */
2738
2739             if (OP(noper) == NOTHING) {
2740                 regnode *noper_next= regnext(noper);
2741                 if (noper_next != tail && OP(noper_next) == flags) {
2742                     noper = noper_next;
2743                     uc= (U8*)STRING(noper);
2744                     e= uc + STR_LEN(noper);
2745                 }
2746             }
2747
2748             if (OP(noper) != NOTHING) {
2749                 for ( ; uc < e ; uc += len ) {
2750
2751                     TRIE_READ_CHAR;
2752
2753                     if ( uvc < 256 ) {
2754                         charid = trie->charmap[ uvc ];
2755                     } else {
2756                         SV** const svpp = hv_fetch( widecharmap,
2757                                                     (char*)&uvc,
2758                                                     sizeof( UV ),
2759                                                     0);
2760                         if ( !svpp ) {
2761                             charid = 0;
2762                         } else {
2763                             charid=(U16)SvIV( *svpp );
2764                         }
2765                     }
2766                     /* charid is now 0 if we dont know the char read, or
2767                      * nonzero if we do */
2768                     if ( charid ) {
2769
2770                         U16 check;
2771                         U32 newstate = 0;
2772
2773                         charid--;
2774                         if ( !trie->states[ state ].trans.list ) {
2775                             TRIE_LIST_NEW( state );
2776                         }
2777                         for ( check = 1;
2778                               check <= TRIE_LIST_USED( state );
2779                               check++ )
2780                         {
2781                             if ( TRIE_LIST_ITEM( state, check ).forid
2782                                                                     == charid )
2783                             {
2784                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2785                                 break;
2786                             }
2787                         }
2788                         if ( ! newstate ) {
2789                             newstate = next_alloc++;
2790                             prev_states[newstate] = state;
2791                             TRIE_LIST_PUSH( state, charid, newstate );
2792                             transcount++;
2793                         }
2794                         state = newstate;
2795                     } else {
2796                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2797                     }
2798                 }
2799             }
2800             TRIE_HANDLE_WORD(state);
2801
2802         } /* end second pass */
2803
2804         /* next alloc is the NEXT state to be allocated */
2805         trie->statecount = next_alloc;
2806         trie->states = (reg_trie_state *)
2807             PerlMemShared_realloc( trie->states,
2808                                    next_alloc
2809                                    * sizeof(reg_trie_state) );
2810
2811         /* and now dump it out before we compress it */
2812         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2813                                                          revcharmap, next_alloc,
2814                                                          depth+1)
2815         );
2816
2817         trie->trans = (reg_trie_trans *)
2818             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2819         {
2820             U32 state;
2821             U32 tp = 0;
2822             U32 zp = 0;
2823
2824
2825             for( state=1 ; state < next_alloc ; state ++ ) {
2826                 U32 base=0;
2827
2828                 /*
2829                 DEBUG_TRIE_COMPILE_MORE_r(
2830                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
2831                 );
2832                 */
2833
2834                 if (trie->states[state].trans.list) {
2835                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2836                     U16 maxid=minid;
2837                     U16 idx;
2838
2839                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2840                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2841                         if ( forid < minid ) {
2842                             minid=forid;
2843                         } else if ( forid > maxid ) {
2844                             maxid=forid;
2845                         }
2846                     }
2847                     if ( transcount < tp + maxid - minid + 1) {
2848                         transcount *= 2;
2849                         trie->trans = (reg_trie_trans *)
2850                             PerlMemShared_realloc( trie->trans,
2851                                                      transcount
2852                                                      * sizeof(reg_trie_trans) );
2853                         Zero( trie->trans + (transcount / 2),
2854                               transcount / 2,
2855                               reg_trie_trans );
2856                     }
2857                     base = trie->uniquecharcount + tp - minid;
2858                     if ( maxid == minid ) {
2859                         U32 set = 0;
2860                         for ( ; zp < tp ; zp++ ) {
2861                             if ( ! trie->trans[ zp ].next ) {
2862                                 base = trie->uniquecharcount + zp - minid;
2863                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2864                                                                    1).newstate;
2865                                 trie->trans[ zp ].check = state;
2866                                 set = 1;
2867                                 break;
2868                             }
2869                         }
2870                         if ( !set ) {
2871                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2872                                                                    1).newstate;
2873                             trie->trans[ tp ].check = state;
2874                             tp++;
2875                             zp = tp;
2876                         }
2877                     } else {
2878                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2879                             const U32 tid = base
2880                                            - trie->uniquecharcount
2881                                            + TRIE_LIST_ITEM( state, idx ).forid;
2882                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2883                                                                 idx ).newstate;
2884                             trie->trans[ tid ].check = state;
2885                         }
2886                         tp += ( maxid - minid + 1 );
2887                     }
2888                     Safefree(trie->states[ state ].trans.list);
2889                 }
2890                 /*
2891                 DEBUG_TRIE_COMPILE_MORE_r(
2892                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
2893                 );
2894                 */
2895                 trie->states[ state ].trans.base=base;
2896             }
2897             trie->lasttrans = tp + 1;
2898         }
2899     } else {
2900         /*
2901            Second Pass -- Flat Table Representation.
2902
2903            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2904            each.  We know that we will need Charcount+1 trans at most to store
2905            the data (one row per char at worst case) So we preallocate both
2906            structures assuming worst case.
2907
2908            We then construct the trie using only the .next slots of the entry
2909            structs.
2910
2911            We use the .check field of the first entry of the node temporarily
2912            to make compression both faster and easier by keeping track of how
2913            many non zero fields are in the node.
2914
2915            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2916            transition.
2917
2918            There are two terms at use here: state as a TRIE_NODEIDX() which is
2919            a number representing the first entry of the node, and state as a
2920            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2921            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2922            if there are 2 entrys per node. eg:
2923
2924              A B       A B
2925           1. 2 4    1. 3 7
2926           2. 0 3    3. 0 5
2927           3. 0 0    5. 0 0
2928           4. 0 0    7. 0 0
2929
2930            The table is internally in the right hand, idx form. However as we
2931            also have to deal with the states array which is indexed by nodenum
2932            we have to use TRIE_NODENUM() to convert.
2933
2934         */
2935         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2936             "%*sCompiling trie using table compiler\n",
2937             (int)depth * 2 + 2, ""));
2938
2939         trie->trans = (reg_trie_trans *)
2940             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2941                                   * trie->uniquecharcount + 1,
2942                                   sizeof(reg_trie_trans) );
2943         trie->states = (reg_trie_state *)
2944             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2945                                   sizeof(reg_trie_state) );
2946         next_alloc = trie->uniquecharcount + 1;
2947
2948
2949         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2950
2951             regnode *noper   = NEXTOPER( cur );
2952             const U8 *uc     = (U8*)STRING( noper );
2953             const U8 *e      = uc + STR_LEN( noper );
2954
2955             U32 state        = 1;         /* required init */
2956
2957             U16 charid       = 0;         /* sanity init */
2958             U32 accept_state = 0;         /* sanity init */
2959
2960             U32 wordlen      = 0;         /* required init */
2961
2962             if (OP(noper) == NOTHING) {
2963                 regnode *noper_next= regnext(noper);
2964                 if (noper_next != tail && OP(noper_next) == flags) {
2965                     noper = noper_next;
2966                     uc= (U8*)STRING(noper);
2967                     e= uc + STR_LEN(noper);
2968                 }
2969             }
2970
2971             if ( OP(noper) != NOTHING ) {
2972                 for ( ; uc < e ; uc += len ) {
2973
2974                     TRIE_READ_CHAR;
2975
2976                     if ( uvc < 256 ) {
2977                         charid = trie->charmap[ uvc ];
2978                     } else {
2979                         SV* const * const svpp = hv_fetch( widecharmap,
2980                                                            (char*)&uvc,
2981                                                            sizeof( UV ),
2982                                                            0);
2983                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2984                     }
2985                     if ( charid ) {
2986                         charid--;
2987                         if ( !trie->trans[ state + charid ].next ) {
2988                             trie->trans[ state + charid ].next = next_alloc;
2989                             trie->trans[ state ].check++;
2990                             prev_states[TRIE_NODENUM(next_alloc)]
2991                                     = TRIE_NODENUM(state);
2992                             next_alloc += trie->uniquecharcount;
2993                         }
2994                         state = trie->trans[ state + charid ].next;
2995                     } else {
2996                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2997                     }
2998                     /* charid is now 0 if we dont know the char read, or
2999                      * nonzero if we do */
3000                 }
3001             }
3002             accept_state = TRIE_NODENUM( state );
3003             TRIE_HANDLE_WORD(accept_state);
3004
3005         } /* end second pass */
3006
3007         /* and now dump it out before we compress it */
3008         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3009                                                           revcharmap,
3010                                                           next_alloc, depth+1));
3011
3012         {
3013         /*
3014            * Inplace compress the table.*
3015
3016            For sparse data sets the table constructed by the trie algorithm will
3017            be mostly 0/FAIL transitions or to put it another way mostly empty.
3018            (Note that leaf nodes will not contain any transitions.)
3019
3020            This algorithm compresses the tables by eliminating most such
3021            transitions, at the cost of a modest bit of extra work during lookup:
3022
3023            - Each states[] entry contains a .base field which indicates the
3024            index in the state[] array wheres its transition data is stored.
3025
3026            - If .base is 0 there are no valid transitions from that node.
3027
3028            - If .base is nonzero then charid is added to it to find an entry in
3029            the trans array.
3030
3031            -If trans[states[state].base+charid].check!=state then the
3032            transition is taken to be a 0/Fail transition. Thus if there are fail
3033            transitions at the front of the node then the .base offset will point
3034            somewhere inside the previous nodes data (or maybe even into a node
3035            even earlier), but the .check field determines if the transition is
3036            valid.
3037
3038            XXX - wrong maybe?
3039            The following process inplace converts the table to the compressed
3040            table: We first do not compress the root node 1,and mark all its
3041            .check pointers as 1 and set its .base pointer as 1 as well. This
3042            allows us to do a DFA construction from the compressed table later,
3043            and ensures that any .base pointers we calculate later are greater
3044            than 0.
3045
3046            - We set 'pos' to indicate the first entry of the second node.
3047
3048            - We then iterate over the columns of the node, finding the first and
3049            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3050            and set the .check pointers accordingly, and advance pos
3051            appropriately and repreat for the next node. Note that when we copy
3052            the next pointers we have to convert them from the original
3053            NODEIDX form to NODENUM form as the former is not valid post
3054            compression.
3055
3056            - If a node has no transitions used we mark its base as 0 and do not
3057            advance the pos pointer.
3058
3059            - If a node only has one transition we use a second pointer into the
3060            structure to fill in allocated fail transitions from other states.
3061            This pointer is independent of the main pointer and scans forward
3062            looking for null transitions that are allocated to a state. When it
3063            finds one it writes the single transition into the "hole".  If the
3064            pointer doesnt find one the single transition is appended as normal.
3065
3066            - Once compressed we can Renew/realloc the structures to release the
3067            excess space.
3068
3069            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3070            specifically Fig 3.47 and the associated pseudocode.
3071
3072            demq
3073         */
3074         const U32 laststate = TRIE_NODENUM( next_alloc );
3075         U32 state, charid;
3076         U32 pos = 0, zp=0;
3077         trie->statecount = laststate;
3078
3079         for ( state = 1 ; state < laststate ; state++ ) {
3080             U8 flag = 0;
3081             const U32 stateidx = TRIE_NODEIDX( state );
3082             const U32 o_used = trie->trans[ stateidx ].check;
3083             U32 used = trie->trans[ stateidx ].check;
3084             trie->trans[ stateidx ].check = 0;
3085
3086             for ( charid = 0;
3087                   used && charid < trie->uniquecharcount;
3088                   charid++ )
3089             {
3090                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3091                     if ( trie->trans[ stateidx + charid ].next ) {
3092                         if (o_used == 1) {
3093                             for ( ; zp < pos ; zp++ ) {
3094                                 if ( ! trie->trans[ zp ].next ) {
3095                                     break;
3096                                 }
3097                             }
3098                             trie->states[ state ].trans.base
3099                                                     = zp
3100                                                       + trie->uniquecharcount
3101                                                       - charid ;
3102                             trie->trans[ zp ].next
3103                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3104                                                              + charid ].next );
3105                             trie->trans[ zp ].check = state;
3106                             if ( ++zp > pos ) pos = zp;
3107                             break;
3108                         }
3109                         used--;
3110                     }
3111                     if ( !flag ) {
3112                         flag = 1;
3113                         trie->states[ state ].trans.base
3114                                        = pos + trie->uniquecharcount - charid ;
3115                     }
3116                     trie->trans[ pos ].next
3117                         = SAFE_TRIE_NODENUM(
3118                                        trie->trans[ stateidx + charid ].next );
3119                     trie->trans[ pos ].check = state;
3120                     pos++;
3121                 }
3122             }
3123         }
3124         trie->lasttrans = pos + 1;
3125         trie->states = (reg_trie_state *)
3126             PerlMemShared_realloc( trie->states, laststate
3127                                    * sizeof(reg_trie_state) );
3128         DEBUG_TRIE_COMPILE_MORE_r(
3129             PerlIO_printf( Perl_debug_log,
3130                 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
3131                 (int)depth * 2 + 2,"",
3132                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3133                        + 1 ),
3134                 (IV)next_alloc,
3135                 (IV)pos,
3136                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3137             );
3138
3139         } /* end table compress */
3140     }
3141     DEBUG_TRIE_COMPILE_MORE_r(
3142             PerlIO_printf(Perl_debug_log,
3143                 "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
3144                 (int)depth * 2 + 2, "",
3145                 (UV)trie->statecount,
3146                 (UV)trie->lasttrans)
3147     );
3148     /* resize the trans array to remove unused space */
3149     trie->trans = (reg_trie_trans *)
3150         PerlMemShared_realloc( trie->trans, trie->lasttrans
3151                                * sizeof(reg_trie_trans) );
3152
3153     {   /* Modify the program and insert the new TRIE node */
3154         U8 nodetype =(U8)(flags & 0xFF);
3155         char *str=NULL;
3156
3157 #ifdef DEBUGGING
3158         regnode *optimize = NULL;
3159 #ifdef RE_TRACK_PATTERN_OFFSETS
3160
3161         U32 mjd_offset = 0;
3162         U32 mjd_nodelen = 0;
3163 #endif /* RE_TRACK_PATTERN_OFFSETS */
3164 #endif /* DEBUGGING */
3165         /*
3166            This means we convert either the first branch or the first Exact,
3167            depending on whether the thing following (in 'last') is a branch
3168            or not and whther first is the startbranch (ie is it a sub part of
3169            the alternation or is it the whole thing.)
3170            Assuming its a sub part we convert the EXACT otherwise we convert
3171            the whole branch sequence, including the first.
3172          */
3173         /* Find the node we are going to overwrite */
3174         if ( first != startbranch || OP( last ) == BRANCH ) {
3175             /* branch sub-chain */
3176             NEXT_OFF( first ) = (U16)(last - first);
3177 #ifdef RE_TRACK_PATTERN_OFFSETS
3178             DEBUG_r({
3179                 mjd_offset= Node_Offset((convert));
3180                 mjd_nodelen= Node_Length((convert));
3181             });
3182 #endif
3183             /* whole branch chain */
3184         }
3185 #ifdef RE_TRACK_PATTERN_OFFSETS
3186         else {
3187             DEBUG_r({
3188                 const  regnode *nop = NEXTOPER( convert );
3189                 mjd_offset= Node_Offset((nop));
3190                 mjd_nodelen= Node_Length((nop));
3191             });
3192         }
3193         DEBUG_OPTIMISE_r(
3194             PerlIO_printf(Perl_debug_log,
3195                 "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
3196                 (int)depth * 2 + 2, "",
3197                 (UV)mjd_offset, (UV)mjd_nodelen)
3198         );
3199 #endif
3200         /* But first we check to see if there is a common prefix we can
3201            split out as an EXACT and put in front of the TRIE node.  */
3202         trie->startstate= 1;
3203         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3204             U32 state;
3205             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3206                 U32 ofs = 0;
3207                 I32 idx = -1;
3208                 U32 count = 0;
3209                 const U32 base = trie->states[ state ].trans.base;
3210
3211                 if ( trie->states[state].wordnum )
3212                         count = 1;
3213
3214                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3215                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3216                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3217                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3218                     {
3219                         if ( ++count > 1 ) {
3220                             SV **tmp = av_fetch( revcharmap, ofs, 0);
3221                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
3222                             if ( state == 1 ) break;
3223                             if ( count == 2 ) {
3224                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3225                                 DEBUG_OPTIMISE_r(
3226                                     PerlIO_printf(Perl_debug_log,
3227                                         "%*sNew Start State=%"UVuf" Class: [",
3228                                         (int)depth * 2 + 2, "",
3229                                         (UV)state));
3230                                 if (idx >= 0) {
3231                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
3232                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3233
3234                                     TRIE_BITMAP_SET(trie,*ch);
3235                                     if ( folder )
3236                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
3237                                     DEBUG_OPTIMISE_r(
3238                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
3239                                     );
3240                                 }
3241                             }
3242                             TRIE_BITMAP_SET(trie,*ch);
3243                             if ( folder )
3244                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
3245                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
3246                         }
3247                         idx = ofs;
3248                     }
3249                 }
3250                 if ( count == 1 ) {
3251                     SV **tmp = av_fetch( revcharmap, idx, 0);
3252                     STRLEN len;
3253                     char *ch = SvPV( *tmp, len );
3254                     DEBUG_OPTIMISE_r({
3255                         SV *sv=sv_newmortal();
3256                         PerlIO_printf( Perl_debug_log,
3257                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
3258                             (int)depth * 2 + 2, "",
3259                             (UV)state, (UV)idx,
3260                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3261                                 PL_colors[0], PL_colors[1],
3262                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3263                                 PERL_PV_ESCAPE_FIRSTCHAR
3264                             )
3265                         );
3266                     });
3267                     if ( state==1 ) {
3268                         OP( convert ) = nodetype;
3269                         str=STRING(convert);
3270                         STR_LEN(convert)=0;
3271                     }
3272                     STR_LEN(convert) += len;
3273                     while (len--)
3274                         *str++ = *ch++;
3275                 } else {
3276 #ifdef DEBUGGING
3277                     if (state>1)
3278                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
3279 #endif
3280                     break;
3281                 }
3282             }
3283             trie->prefixlen = (state-1);
3284             if (str) {
3285                 regnode *n = convert+NODE_SZ_STR(convert);
3286                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3287                 trie->startstate = state;
3288                 trie->minlen -= (state - 1);
3289                 trie->maxlen -= (state - 1);
3290 #ifdef DEBUGGING
3291                /* At least the UNICOS C compiler choked on this
3292                 * being argument to DEBUG_r(), so let's just have
3293                 * it right here. */
3294                if (
3295 #ifdef PERL_EXT_RE_BUILD
3296                    1
3297 #else
3298                    DEBUG_r_TEST
3299 #endif
3300                    ) {
3301                    regnode *fix = convert;
3302                    U32 word = trie->wordcount;
3303                    mjd_nodelen++;
3304                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3305                    while( ++fix < n ) {
3306                        Set_Node_Offset_Length(fix, 0, 0);
3307                    }
3308                    while (word--) {
3309                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3310                        if (tmp) {
3311                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3312                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3313                            else
3314                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3315                        }
3316                    }
3317                }
3318 #endif
3319                 if (trie->maxlen) {
3320                     convert = n;
3321                 } else {
3322                     NEXT_OFF(convert) = (U16)(tail - convert);
3323                     DEBUG_r(optimize= n);
3324                 }
3325             }
3326         }
3327         if (!jumper)
3328             jumper = last;
3329         if ( trie->maxlen ) {
3330             NEXT_OFF( convert ) = (U16)(tail - convert);
3331             ARG_SET( convert, data_slot );
3332             /* Store the offset to the first unabsorbed branch in
3333                jump[0], which is otherwise unused by the jump logic.
3334                We use this when dumping a trie and during optimisation. */
3335             if (trie->jump)
3336                 trie->jump[0] = (U16)(nextbranch - convert);
3337
3338             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3339              *   and there is a bitmap
3340              *   and the first "jump target" node we found leaves enough room
3341              * then convert the TRIE node into a TRIEC node, with the bitmap
3342              * embedded inline in the opcode - this is hypothetically faster.
3343              */
3344             if ( !trie->states[trie->startstate].wordnum
3345                  && trie->bitmap
3346                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3347             {
3348                 OP( convert ) = TRIEC;
3349                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3350                 PerlMemShared_free(trie->bitmap);
3351                 trie->bitmap= NULL;
3352             } else
3353                 OP( convert ) = TRIE;
3354
3355             /* store the type in the flags */
3356             convert->flags = nodetype;
3357             DEBUG_r({
3358             optimize = convert
3359                       + NODE_STEP_REGNODE
3360                       + regarglen[ OP( convert ) ];
3361             });
3362             /* XXX We really should free up the resource in trie now,
3363                    as we won't use them - (which resources?) dmq */
3364         }
3365         /* needed for dumping*/
3366         DEBUG_r(if (optimize) {
3367             regnode *opt = convert;
3368
3369             while ( ++opt < optimize) {
3370                 Set_Node_Offset_Length(opt,0,0);
3371             }
3372             /*
3373                 Try to clean up some of the debris left after the
3374                 optimisation.
3375              */
3376             while( optimize < jumper ) {
3377                 mjd_nodelen += Node_Length((optimize));
3378                 OP( optimize ) = OPTIMIZED;
3379                 Set_Node_Offset_Length(optimize,0,0);
3380                 optimize++;
3381             }
3382             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3383         });
3384     } /* end node insert */
3385
3386     /*  Finish populating the prev field of the wordinfo array.  Walk back
3387      *  from each accept state until we find another accept state, and if
3388      *  so, point the first word's .prev field at the second word. If the
3389      *  second already has a .prev field set, stop now. This will be the
3390      *  case either if we've already processed that word's accept state,
3391      *  or that state had multiple words, and the overspill words were
3392      *  already linked up earlier.
3393      */
3394     {
3395         U16 word;
3396         U32 state;
3397         U16 prev;
3398
3399         for (word=1; word <= trie->wordcount; word++) {
3400             prev = 0;
3401             if (trie->wordinfo[word].prev)
3402                 continue;
3403             state = trie->wordinfo[word].accept;
3404             while (state) {
3405                 state = prev_states[state];
3406                 if (!state)
3407                     break;
3408                 prev = trie->states[state].wordnum;
3409                 if (prev)
3410                     break;
3411             }
3412             trie->wordinfo[word].prev = prev;
3413         }
3414         Safefree(prev_states);
3415     }
3416
3417
3418     /* and now dump out the compressed format */
3419     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3420
3421     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3422 #ifdef DEBUGGING
3423     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3424     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3425 #else
3426     SvREFCNT_dec_NN(revcharmap);
3427 #endif
3428     return trie->jump
3429            ? MADE_JUMP_TRIE
3430            : trie->startstate>1
3431              ? MADE_EXACT_TRIE
3432              : MADE_TRIE;
3433 }
3434
3435 STATIC regnode *
3436 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3437 {
3438 /* The Trie is constructed and compressed now so we can build a fail array if
3439  * it's needed
3440
3441    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3442    3.32 in the
3443    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3444    Ullman 1985/88
3445    ISBN 0-201-10088-6
3446
3447    We find the fail state for each state in the trie, this state is the longest
3448    proper suffix of the current state's 'word' that is also a proper prefix of
3449    another word in our trie. State 1 represents the word '' and is thus the
3450    default fail state. This allows the DFA not to have to restart after its
3451    tried and failed a word at a given point, it simply continues as though it
3452    had been matching the other word in the first place.
3453    Consider
3454       'abcdgu'=~/abcdefg|cdgu/
3455    When we get to 'd' we are still matching the first word, we would encounter
3456    'g' which would fail, which would bring us to the state representing 'd' in
3457    the second word where we would try 'g' and succeed, proceeding to match
3458    'cdgu'.
3459  */
3460  /* add a fail transition */
3461     const U32 trie_offset = ARG(source);
3462     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3463     U32 *q;
3464     const U32 ucharcount = trie->uniquecharcount;
3465     const U32 numstates = trie->statecount;
3466     const U32 ubound = trie->lasttrans + ucharcount;
3467     U32 q_read = 0;
3468     U32 q_write = 0;
3469     U32 charid;
3470     U32 base = trie->states[ 1 ].trans.base;
3471     U32 *fail;
3472     reg_ac_data *aho;
3473     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3474     regnode *stclass;
3475     GET_RE_DEBUG_FLAGS_DECL;
3476
3477     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3478     PERL_UNUSED_CONTEXT;
3479 #ifndef DEBUGGING
3480     PERL_UNUSED_ARG(depth);
3481 #endif
3482
3483     if ( OP(source) == TRIE ) {
3484         struct regnode_1 *op = (struct regnode_1 *)
3485             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3486         StructCopy(source,op,struct regnode_1);
3487         stclass = (regnode *)op;
3488     } else {
3489         struct regnode_charclass *op = (struct regnode_charclass *)
3490             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3491         StructCopy(source,op,struct regnode_charclass);
3492         stclass = (regnode *)op;
3493     }
3494     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3495
3496     ARG_SET( stclass, data_slot );
3497     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3498     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3499     aho->trie=trie_offset;
3500     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3501     Copy( trie->states, aho->states, numstates, reg_trie_state );
3502     Newxz( q, numstates, U32);
3503     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3504     aho->refcount = 1;
3505     fail = aho->fail;
3506     /* initialize fail[0..1] to be 1 so that we always have
3507        a valid final fail state */
3508     fail[ 0 ] = fail[ 1 ] = 1;
3509
3510     for ( charid = 0; charid < ucharcount ; charid++ ) {
3511         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3512         if ( newstate ) {
3513             q[ q_write ] = newstate;
3514             /* set to point at the root */
3515             fail[ q[ q_write++ ] ]=1;
3516         }
3517     }
3518     while ( q_read < q_write) {
3519         const U32 cur = q[ q_read++ % numstates ];
3520         base = trie->states[ cur ].trans.base;
3521
3522         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3523             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3524             if (ch_state) {
3525                 U32 fail_state = cur;
3526                 U32 fail_base;
3527                 do {
3528                     fail_state = fail[ fail_state ];
3529                     fail_base = aho->states[ fail_state ].trans.base;
3530                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3531
3532                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3533                 fail[ ch_state ] = fail_state;
3534                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3535                 {
3536                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3537                 }
3538                 q[ q_write++ % numstates] = ch_state;
3539             }
3540         }
3541     }
3542     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3543        when we fail in state 1, this allows us to use the
3544        charclass scan to find a valid start char. This is based on the principle
3545        that theres a good chance the string being searched contains lots of stuff
3546        that cant be a start char.
3547      */
3548     fail[ 0 ] = fail[ 1 ] = 0;
3549     DEBUG_TRIE_COMPILE_r({
3550         PerlIO_printf(Perl_debug_log,
3551                       "%*sStclass Failtable (%"UVuf" states): 0",
3552                       (int)(depth * 2), "", (UV)numstates
3553         );
3554         for( q_read=1; q_read<numstates; q_read++ ) {
3555             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
3556         }
3557         PerlIO_printf(Perl_debug_log, "\n");
3558     });
3559     Safefree(q);
3560     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3561     return stclass;
3562 }
3563
3564
3565 #define DEBUG_PEEP(str,scan,depth) \
3566     DEBUG_OPTIMISE_r({if (scan){ \
3567        regnode *Next = regnext(scan); \
3568        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state); \
3569        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)", \
3570            (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3571            Next ? (REG_NODE_NUM(Next)) : 0 ); \
3572        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3573        PerlIO_printf(Perl_debug_log, "\n"); \
3574    }});
3575
3576 /* The below joins as many adjacent EXACTish nodes as possible into a single
3577  * one.  The regop may be changed if the node(s) contain certain sequences that
3578  * require special handling.  The joining is only done if:
3579  * 1) there is room in the current conglomerated node to entirely contain the
3580  *    next one.
3581  * 2) they are the exact same node type
3582  *
3583  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3584  * these get optimized out
3585  *
3586  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3587  * as possible, even if that means splitting an existing node so that its first
3588  * part is moved to the preceeding node.  This would maximise the efficiency of
3589  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3590  * EXACTFish nodes into portions that don't change under folding vs those that
3591  * do.  Those portions that don't change may be the only things in the pattern that
3592  * could be used to find fixed and floating strings.
3593  *
3594  * If a node is to match under /i (folded), the number of characters it matches
3595  * can be different than its character length if it contains a multi-character
3596  * fold.  *min_subtract is set to the total delta number of characters of the
3597  * input nodes.
3598  *
3599  * And *unfolded_multi_char is set to indicate whether or not the node contains
3600  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3601  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3602  * SMALL LETTER SHARP S, as only if the target string being matched against
3603  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3604  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3605  * whose components are all above the Latin1 range are not run-time locale
3606  * dependent, and have already been folded by the time this function is
3607  * called.)
3608  *
3609  * This is as good a place as any to discuss the design of handling these
3610  * multi-character fold sequences.  It's been wrong in Perl for a very long
3611  * time.  There are three code points in Unicode whose multi-character folds
3612  * were long ago discovered to mess things up.  The previous designs for
3613  * dealing with these involved assigning a special node for them.  This
3614  * approach doesn't always work, as evidenced by this example:
3615  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3616  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3617  * would match just the \xDF, it won't be able to handle the case where a
3618  * successful match would have to cross the node's boundary.  The new approach
3619  * that hopefully generally solves the problem generates an EXACTFU_SS node
3620  * that is "sss" in this case.
3621  *
3622  * It turns out that there are problems with all multi-character folds, and not
3623  * just these three.  Now the code is general, for all such cases.  The
3624  * approach taken is:
3625  * 1)   This routine examines each EXACTFish node that could contain multi-
3626  *      character folded sequences.  Since a single character can fold into
3627  *      such a sequence, the minimum match length for this node is less than
3628  *      the number of characters in the node.  This routine returns in
3629  *      *min_subtract how many characters to subtract from the the actual
3630  *      length of the string to get a real minimum match length; it is 0 if
3631  *      there are no multi-char foldeds.  This delta is used by the caller to
3632  *      adjust the min length of the match, and the delta between min and max,
3633  *      so that the optimizer doesn't reject these possibilities based on size
3634  *      constraints.
3635  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3636  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3637  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3638  *      there is a possible fold length change.  That means that a regular
3639  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3640  *      with length changes, and so can be processed faster.  regexec.c takes
3641  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3642  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3643  *      known until runtime).  This saves effort in regex matching.  However,
3644  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3645  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3646  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3647  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3648  *      possibilities for the non-UTF8 patterns are quite simple, except for
3649  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3650  *      members of a fold-pair, and arrays are set up for all of them so that
3651  *      the other member of the pair can be found quickly.  Code elsewhere in
3652  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3653  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3654  *      described in the next item.
3655  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3656  *      validity of the fold won't be known until runtime, and so must remain
3657  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3658  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3659  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3660  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3661  *      The reason this is a problem is that the optimizer part of regexec.c
3662  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3663  *      that a character in the pattern corresponds to at most a single
3664  *      character in the target string.  (And I do mean character, and not byte
3665  *      here, unlike other parts of the documentation that have never been
3666  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3667  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3668  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3669  *      nodes, violate the assumption, and they are the only instances where it
3670  *      is violated.  I'm reluctant to try to change the assumption, as the
3671  *      code involved is impenetrable to me (khw), so instead the code here
3672  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3673  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3674  *      boolean indicating whether or not the node contains such a fold.  When
3675  *      it is true, the caller sets a flag that later causes the optimizer in
3676  *      this file to not set values for the floating and fixed string lengths,
3677  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3678  *      assumption.  Thus, there is no optimization based on string lengths for
3679  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3680  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3681  *      assumption is wrong only in these cases is that all other non-UTF-8
3682  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3683  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3684  *      EXACTF nodes because we don't know at compile time if it actually
3685  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3686  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3687  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3688  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3689  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3690  *      string would require the pattern to be forced into UTF-8, the overhead
3691  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3692  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3693  *      locale.)
3694  *
3695  *      Similarly, the code that generates tries doesn't currently handle
3696  *      not-already-folded multi-char folds, and it looks like a pain to change
3697  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3698  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3699  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3700  *      using /iaa matching will be doing so almost entirely with ASCII
3701  *      strings, so this should rarely be encountered in practice */
3702
3703 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3704     if (PL_regkind[OP(scan)] == EXACT) \
3705         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3706
3707 STATIC U32
3708 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3709                    UV *min_subtract, bool *unfolded_multi_char,
3710                    U32 flags,regnode *val, U32 depth)
3711 {
3712     /* Merge several consecutive EXACTish nodes into one. */
3713     regnode *n = regnext(scan);
3714     U32 stringok = 1;
3715     regnode *next = scan + NODE_SZ_STR(scan);
3716     U32 merged = 0;
3717     U32 stopnow = 0;
3718 #ifdef DEBUGGING
3719     regnode *stop = scan;
3720     GET_RE_DEBUG_FLAGS_DECL;
3721 #else
3722     PERL_UNUSED_ARG(depth);
3723 #endif
3724
3725     PERL_ARGS_ASSERT_JOIN_EXACT;
3726 #ifndef EXPERIMENTAL_INPLACESCAN
3727     PERL_UNUSED_ARG(flags);
3728     PERL_UNUSED_ARG(val);
3729 #endif
3730     DEBUG_PEEP("join",scan,depth);
3731
3732     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3733      * EXACT ones that are mergeable to the current one. */
3734     while (n
3735            && (PL_regkind[OP(n)] == NOTHING
3736                || (stringok && OP(n) == OP(scan)))
3737            && NEXT_OFF(n)
3738            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3739     {
3740
3741         if (OP(n) == TAIL || n > next)
3742             stringok = 0;
3743         if (PL_regkind[OP(n)] == NOTHING) {
3744             DEBUG_PEEP("skip:",n,depth);
3745             NEXT_OFF(scan) += NEXT_OFF(n);
3746             next = n + NODE_STEP_REGNODE;
3747 #ifdef DEBUGGING
3748             if (stringok)
3749                 stop = n;
3750 #endif
3751             n = regnext(n);
3752         }
3753         else if (stringok) {
3754             const unsigned int oldl = STR_LEN(scan);
3755             regnode * const nnext = regnext(n);
3756
3757             /* XXX I (khw) kind of doubt that this works on platforms (should
3758              * Perl ever run on one) where U8_MAX is above 255 because of lots
3759              * of other assumptions */
3760             /* Don't join if the sum can't fit into a single node */
3761             if (oldl + STR_LEN(n) > U8_MAX)
3762                 break;
3763
3764             DEBUG_PEEP("merg",n,depth);
3765             merged++;
3766
3767             NEXT_OFF(scan) += NEXT_OFF(n);
3768             STR_LEN(scan) += STR_LEN(n);
3769             next = n + NODE_SZ_STR(n);
3770             /* Now we can overwrite *n : */
3771             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3772 #ifdef DEBUGGING
3773             stop = next - 1;
3774 #endif
3775             n = nnext;
3776             if (stopnow) break;
3777         }
3778
3779 #ifdef EXPERIMENTAL_INPLACESCAN
3780         if (flags && !NEXT_OFF(n)) {
3781             DEBUG_PEEP("atch", val, depth);
3782             if (reg_off_by_arg[OP(n)]) {
3783                 ARG_SET(n, val - n);
3784             }
3785             else {
3786                 NEXT_OFF(n) = val - n;
3787             }
3788             stopnow = 1;
3789         }
3790 #endif
3791     }
3792
3793     *min_subtract = 0;
3794     *unfolded_multi_char = FALSE;
3795
3796     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3797      * can now analyze for sequences of problematic code points.  (Prior to
3798      * this final joining, sequences could have been split over boundaries, and
3799      * hence missed).  The sequences only happen in folding, hence for any
3800      * non-EXACT EXACTish node */
3801     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3802         U8* s0 = (U8*) STRING(scan);
3803         U8* s = s0;
3804         U8* s_end = s0 + STR_LEN(scan);
3805
3806         int total_count_delta = 0;  /* Total delta number of characters that
3807                                        multi-char folds expand to */
3808
3809         /* One pass is made over the node's string looking for all the
3810          * possibilities.  To avoid some tests in the loop, there are two main
3811          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3812          * non-UTF-8 */
3813         if (UTF) {
3814             U8* folded = NULL;
3815
3816             if (OP(scan) == EXACTFL) {
3817                 U8 *d;
3818
3819                 /* An EXACTFL node would already have been changed to another
3820                  * node type unless there is at least one character in it that
3821                  * is problematic; likely a character whose fold definition
3822                  * won't be known until runtime, and so has yet to be folded.
3823                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3824                  * to handle the UTF-8 case, we need to create a temporary
3825                  * folded copy using UTF-8 locale rules in order to analyze it.
3826                  * This is because our macros that look to see if a sequence is
3827                  * a multi-char fold assume everything is folded (otherwise the
3828                  * tests in those macros would be too complicated and slow).
3829                  * Note that here, the non-problematic folds will have already
3830                  * been done, so we can just copy such characters.  We actually
3831                  * don't completely fold the EXACTFL string.  We skip the
3832                  * unfolded multi-char folds, as that would just create work
3833                  * below to figure out the size they already are */
3834
3835                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3836                 d = folded;
3837                 while (s < s_end) {
3838                     STRLEN s_len = UTF8SKIP(s);
3839                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3840                         Copy(s, d, s_len, U8);
3841                         d += s_len;
3842                     }
3843                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3844                         *unfolded_multi_char = TRUE;
3845                         Copy(s, d, s_len, U8);
3846                         d += s_len;
3847                     }
3848                     else if (isASCII(*s)) {
3849                         *(d++) = toFOLD(*s);
3850                     }
3851                     else {
3852                         STRLEN len;
3853                         _to_utf8_fold_flags(s, d, &len, FOLD_FLAGS_FULL);
3854                         d += len;
3855                     }
3856                     s += s_len;
3857                 }
3858
3859                 /* Point the remainder of the routine to look at our temporary
3860                  * folded copy */
3861                 s = folded;
3862                 s_end = d;
3863             } /* End of creating folded copy of EXACTFL string */
3864
3865             /* Examine the string for a multi-character fold sequence.  UTF-8
3866              * patterns have all characters pre-folded by the time this code is
3867              * executed */
3868             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3869                                      length sequence we are looking for is 2 */
3870             {
3871                 int count = 0;  /* How many characters in a multi-char fold */
3872                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3873                 if (! len) {    /* Not a multi-char fold: get next char */
3874                     s += UTF8SKIP(s);
3875                     continue;
3876                 }
3877
3878                 /* Nodes with 'ss' require special handling, except for
3879                  * EXACTFA-ish for which there is no multi-char fold to this */
3880                 if (len == 2 && *s == 's' && *(s+1) == 's'
3881                     && OP(scan) != EXACTFA
3882                     && OP(scan) != EXACTFA_NO_TRIE)
3883                 {
3884                     count = 2;
3885                     if (OP(scan) != EXACTFL) {
3886                         OP(scan) = EXACTFU_SS;
3887                     }
3888                     s += 2;
3889                 }
3890                 else { /* Here is a generic multi-char fold. */
3891                     U8* multi_end  = s + len;
3892
3893                     /* Count how many characters are in it.  In the case of
3894                      * /aa, no folds which contain ASCII code points are
3895                      * allowed, so check for those, and skip if found. */
3896                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3897                         count = utf8_length(s, multi_end);
3898                         s = multi_end;
3899                     }
3900                     else {
3901                         while (s < multi_end) {
3902                             if (isASCII(*s)) {
3903                                 s++;
3904                                 goto next_iteration;
3905                             }
3906                             else {
3907                                 s += UTF8SKIP(s);
3908                             }
3909                             count++;
3910                         }
3911                     }
3912                 }
3913
3914                 /* The delta is how long the sequence is minus 1 (1 is how long
3915                  * the character that folds to the sequence is) */
3916                 total_count_delta += count - 1;
3917               next_iteration: ;
3918             }
3919
3920             /* We created a temporary folded copy of the string in EXACTFL
3921              * nodes.  Therefore we need to be sure it doesn't go below zero,
3922              * as the real string could be shorter */
3923             if (OP(scan) == EXACTFL) {
3924                 int total_chars = utf8_length((U8*) STRING(scan),
3925                                            (U8*) STRING(scan) + STR_LEN(scan));
3926                 if (total_count_delta > total_chars) {
3927                     total_count_delta = total_chars;
3928                 }
3929             }
3930
3931             *min_subtract += total_count_delta;
3932             Safefree(folded);
3933         }
3934         else if (OP(scan) == EXACTFA) {
3935
3936             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3937              * fold to the ASCII range (and there are no existing ones in the
3938              * upper latin1 range).  But, as outlined in the comments preceding
3939              * this function, we need to flag any occurrences of the sharp s.
3940              * This character forbids trie formation (because of added
3941              * complexity) */
3942 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
3943    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
3944                                       || UNICODE_DOT_DOT_VERSION > 0)
3945             while (s < s_end) {
3946                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3947                     OP(scan) = EXACTFA_NO_TRIE;
3948                     *unfolded_multi_char = TRUE;
3949                     break;
3950                 }
3951                 s++;
3952             }
3953         }
3954         else {
3955
3956             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
3957              * folds that are all Latin1.  As explained in the comments
3958              * preceding this function, we look also for the sharp s in EXACTF
3959              * and EXACTFL nodes; it can be in the final position.  Otherwise
3960              * we can stop looking 1 byte earlier because have to find at least
3961              * two characters for a multi-fold */
3962             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
3963                               ? s_end
3964                               : s_end -1;
3965
3966             while (s < upper) {
3967                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
3968                 if (! len) {    /* Not a multi-char fold. */
3969                     if (*s == LATIN_SMALL_LETTER_SHARP_S
3970                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
3971                     {
3972                         *unfolded_multi_char = TRUE;
3973                     }
3974                     s++;
3975                     continue;
3976                 }
3977
3978                 if (len == 2
3979                     && isALPHA_FOLD_EQ(*s, 's')
3980                     && isALPHA_FOLD_EQ(*(s+1), 's'))
3981                 {
3982
3983                     /* EXACTF nodes need to know that the minimum length
3984                      * changed so that a sharp s in the string can match this
3985                      * ss in the pattern, but they remain EXACTF nodes, as they
3986                      * won't match this unless the target string is is UTF-8,
3987                      * which we don't know until runtime.  EXACTFL nodes can't
3988                      * transform into EXACTFU nodes */
3989                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
3990                         OP(scan) = EXACTFU_SS;
3991                     }
3992                 }
3993
3994                 *min_subtract += len - 1;
3995                 s += len;
3996             }
3997 #endif
3998         }
3999     }
4000
4001 #ifdef DEBUGGING
4002     /* Allow dumping but overwriting the collection of skipped
4003      * ops and/or strings with fake optimized ops */
4004     n = scan + NODE_SZ_STR(scan);
4005     while (n <= stop) {
4006         OP(n) = OPTIMIZED;
4007         FLAGS(n) = 0;
4008         NEXT_OFF(n) = 0;
4009         n++;
4010     }
4011 #endif
4012     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
4013     return stopnow;
4014 }
4015
4016 /* REx optimizer.  Converts nodes into quicker variants "in place".
4017    Finds fixed substrings.  */
4018
4019 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4020    to the position after last scanned or to NULL. */
4021
4022 #define INIT_AND_WITHP \
4023     assert(!and_withp); \
4024     Newx(and_withp,1, regnode_ssc); \
4025     SAVEFREEPV(and_withp)
4026
4027
4028 static void
4029 S_unwind_scan_frames(pTHX_ const void *p)
4030 {
4031     scan_frame *f= (scan_frame *)p;
4032     do {
4033         scan_frame *n= f->next_frame;
4034         Safefree(f);
4035         f= n;
4036     } while (f);
4037 }
4038
4039
4040 STATIC SSize_t
4041 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4042                         SSize_t *minlenp, SSize_t *deltap,
4043                         regnode *last,
4044                         scan_data_t *data,
4045                         I32 stopparen,
4046                         U32 recursed_depth,
4047                         regnode_ssc *and_withp,
4048                         U32 flags, U32 depth)
4049                         /* scanp: Start here (read-write). */
4050                         /* deltap: Write maxlen-minlen here. */
4051                         /* last: Stop before this one. */
4052                         /* data: string data about the pattern */
4053                         /* stopparen: treat close N as END */
4054                         /* recursed: which subroutines have we recursed into */
4055                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4056 {
4057     /* There must be at least this number of characters to match */
4058     SSize_t min = 0;
4059     I32 pars = 0, code;
4060     regnode *scan = *scanp, *next;
4061     SSize_t delta = 0;
4062     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4063     int is_inf_internal = 0;            /* The studied chunk is infinite */
4064     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4065     scan_data_t data_fake;
4066     SV *re_trie_maxbuff = NULL;
4067     regnode *first_non_open = scan;
4068     SSize_t stopmin = SSize_t_MAX;
4069     scan_frame *frame = NULL;
4070     GET_RE_DEBUG_FLAGS_DECL;
4071
4072     PERL_ARGS_ASSERT_STUDY_CHUNK;
4073
4074
4075     if ( depth == 0 ) {
4076         while (first_non_open && OP(first_non_open) == OPEN)
4077             first_non_open=regnext(first_non_open);
4078     }
4079
4080
4081   fake_study_recurse:
4082     DEBUG_r(
4083         RExC_study_chunk_recursed_count++;
4084     );
4085     DEBUG_OPTIMISE_MORE_r(
4086     {
4087         PerlIO_printf(Perl_debug_log,
4088             "%*sstudy_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4089             (int)(depth*2), "", (long)stopparen,
4090             (unsigned long)RExC_study_chunk_recursed_count,
4091             (unsigned long)depth, (unsigned long)recursed_depth,
4092             scan,
4093             last);
4094         if (recursed_depth) {
4095             U32 i;
4096             U32 j;
4097             for ( j = 0 ; j < recursed_depth ; j++ ) {
4098                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4099                     if (
4100                         PAREN_TEST(RExC_study_chunk_recursed +
4101                                    ( j * RExC_study_chunk_recursed_bytes), i )
4102                         && (
4103                             !j ||
4104                             !PAREN_TEST(RExC_study_chunk_recursed +
4105                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4106                         )
4107                     ) {
4108                         PerlIO_printf(Perl_debug_log," %d",(int)i);
4109                         break;
4110                     }
4111                 }
4112                 if ( j + 1 < recursed_depth ) {
4113                     PerlIO_printf(Perl_debug_log, ",");
4114                 }
4115             }
4116         }
4117         PerlIO_printf(Perl_debug_log,"\n");
4118     }
4119     );
4120     while ( scan && OP(scan) != END && scan < last ){
4121         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4122                                    node length to get a real minimum (because
4123                                    the folded version may be shorter) */
4124         bool unfolded_multi_char = FALSE;
4125         /* Peephole optimizer: */
4126         DEBUG_STUDYDATA("Peep:", data, depth);
4127         DEBUG_PEEP("Peep", scan, depth);
4128
4129
4130         /* The reason we do this here we need to deal with things like /(?:f)(?:o)(?:o)/
4131          * which cant be dealt with by the normal EXACT parsing code, as each (?:..) is handled
4132          * by a different invocation of reg() -- Yves
4133          */
4134         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4135
4136         /* Follow the next-chain of the current node and optimize
4137            away all the NOTHINGs from it.  */
4138         if (OP(scan) != CURLYX) {
4139             const int max = (reg_off_by_arg[OP(scan)]
4140                        ? I32_MAX
4141                        /* I32 may be smaller than U16 on CRAYs! */
4142                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4143             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4144             int noff;
4145             regnode *n = scan;
4146
4147             /* Skip NOTHING and LONGJMP. */
4148             while ((n = regnext(n))
4149                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4150                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4151                    && off + noff < max)
4152                 off += noff;
4153             if (reg_off_by_arg[OP(scan)])
4154                 ARG(scan) = off;
4155             else
4156                 NEXT_OFF(scan) = off;
4157         }
4158
4159         /* The principal pseudo-switch.  Cannot be a switch, since we
4160            look into several different things.  */
4161         if ( OP(scan) == DEFINEP ) {
4162             SSize_t minlen = 0;
4163             SSize_t deltanext = 0;
4164             SSize_t fake_last_close = 0;
4165             I32 f = SCF_IN_DEFINE;
4166
4167             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4168             scan = regnext(scan);
4169             assert( OP(scan) == IFTHEN );
4170             DEBUG_PEEP("expect IFTHEN", scan, depth);
4171
4172             data_fake.last_closep= &fake_last_close;
4173             minlen = *minlenp;
4174             next = regnext(scan);
4175             scan = NEXTOPER(NEXTOPER(scan));
4176             DEBUG_PEEP("scan", scan, depth);
4177             DEBUG_PEEP("next", next, depth);
4178
4179             /* we suppose the run is continuous, last=next...
4180              * NOTE we dont use the return here! */
4181             (void)study_chunk(pRExC_state, &scan, &minlen,
4182                               &deltanext, next, &data_fake, stopparen,
4183                               recursed_depth, NULL, f, depth+1);
4184
4185             scan = next;
4186         } else
4187         if (
4188             OP(scan) == BRANCH  ||
4189             OP(scan) == BRANCHJ ||
4190             OP(scan) == IFTHEN
4191         ) {
4192             next = regnext(scan);
4193             code = OP(scan);
4194
4195             /* The op(next)==code check below is to see if we
4196              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4197              * IFTHEN is special as it might not appear in pairs.
4198              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4199              * we dont handle it cleanly. */
4200             if (OP(next) == code || code == IFTHEN) {
4201                 /* NOTE - There is similar code to this block below for
4202                  * handling TRIE nodes on a re-study.  If you change stuff here
4203                  * check there too. */
4204                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4205                 regnode_ssc accum;
4206                 regnode * const startbranch=scan;
4207
4208                 if (flags & SCF_DO_SUBSTR) {
4209                     /* Cannot merge strings after this. */
4210                     scan_commit(pRExC_state, data, minlenp, is_inf);
4211                 }
4212
4213                 if (flags & SCF_DO_STCLASS)
4214                     ssc_init_zero(pRExC_state, &accum);
4215
4216                 while (OP(scan) == code) {
4217                     SSize_t deltanext, minnext, fake;
4218                     I32 f = 0;
4219                     regnode_ssc this_class;
4220
4221                     DEBUG_PEEP("Branch", scan, depth);
4222
4223                     num++;
4224                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4225                     if (data) {
4226                         data_fake.whilem_c = data->whilem_c;
4227                         data_fake.last_closep = data->last_closep;
4228                     }
4229                     else
4230                         data_fake.last_closep = &fake;
4231
4232                     data_fake.pos_delta = delta;
4233                     next = regnext(scan);
4234
4235                     scan = NEXTOPER(scan); /* everything */
4236                     if (code != BRANCH)    /* everything but BRANCH */
4237                         scan = NEXTOPER(scan);
4238
4239                     if (flags & SCF_DO_STCLASS) {
4240                         ssc_init(pRExC_state, &this_class);
4241                         data_fake.start_class = &this_class;
4242                         f = SCF_DO_STCLASS_AND;
4243                     }
4244                     if (flags & SCF_WHILEM_VISITED_POS)
4245                         f |= SCF_WHILEM_VISITED_POS;
4246
4247                     /* we suppose the run is continuous, last=next...*/
4248                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4249                                       &deltanext, next, &data_fake, stopparen,
4250                                       recursed_depth, NULL, f,depth+1);
4251
4252                     if (min1 > minnext)
4253                         min1 = minnext;
4254                     if (deltanext == SSize_t_MAX) {
4255                         is_inf = is_inf_internal = 1;
4256                         max1 = SSize_t_MAX;
4257                     } else if (max1 < minnext + deltanext)
4258                         max1 = minnext + deltanext;
4259                     scan = next;
4260                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4261                         pars++;
4262                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4263                         if ( stopmin > minnext)
4264                             stopmin = min + min1;
4265                         flags &= ~SCF_DO_SUBSTR;
4266                         if (data)
4267                             data->flags |= SCF_SEEN_ACCEPT;
4268                     }
4269                     if (data) {
4270                         if (data_fake.flags & SF_HAS_EVAL)
4271                             data->flags |= SF_HAS_EVAL;
4272                         data->whilem_c = data_fake.whilem_c;
4273                     }
4274                     if (flags & SCF_DO_STCLASS)
4275                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4276                 }
4277                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4278                     min1 = 0;
4279                 if (flags & SCF_DO_SUBSTR) {
4280                     data->pos_min += min1;
4281                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4282                         data->pos_delta = SSize_t_MAX;
4283                     else
4284                         data->pos_delta += max1 - min1;
4285                     if (max1 != min1 || is_inf)
4286                         data->longest = &(data->longest_float);
4287                 }
4288                 min += min1;
4289                 if (delta == SSize_t_MAX
4290                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4291                     delta = SSize_t_MAX;
4292                 else
4293                     delta += max1 - min1;
4294                 if (flags & SCF_DO_STCLASS_OR) {
4295                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4296                     if (min1) {
4297                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4298                         flags &= ~SCF_DO_STCLASS;
4299                     }
4300                 }
4301                 else if (flags & SCF_DO_STCLASS_AND) {
4302                     if (min1) {
4303                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4304                         flags &= ~SCF_DO_STCLASS;
4305                     }
4306                     else {
4307                         /* Switch to OR mode: cache the old value of
4308                          * data->start_class */
4309                         INIT_AND_WITHP;
4310                         StructCopy(data->start_class, and_withp, regnode_ssc);
4311                         flags &= ~SCF_DO_STCLASS_AND;
4312                         StructCopy(&accum, data->start_class, regnode_ssc);
4313                         flags |= SCF_DO_STCLASS_OR;
4314                     }
4315                 }
4316
4317                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4318                         OP( startbranch ) == BRANCH )
4319                 {
4320                 /* demq.
4321
4322                    Assuming this was/is a branch we are dealing with: 'scan'
4323                    now points at the item that follows the branch sequence,
4324                    whatever it is. We now start at the beginning of the
4325                    sequence and look for subsequences of
4326
4327                    BRANCH->EXACT=>x1
4328                    BRANCH->EXACT=>x2
4329                    tail
4330
4331                    which would be constructed from a pattern like
4332                    /A|LIST|OF|WORDS/
4333
4334                    If we can find such a subsequence we need to turn the first
4335                    element into a trie and then add the subsequent branch exact
4336                    strings to the trie.
4337
4338                    We have two cases
4339
4340                      1. patterns where the whole set of branches can be
4341                         converted.
4342
4343                      2. patterns where only a subset can be converted.
4344
4345                    In case 1 we can replace the whole set with a single regop
4346                    for the trie. In case 2 we need to keep the start and end
4347                    branches so
4348
4349                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4350                      becomes BRANCH TRIE; BRANCH X;
4351
4352                   There is an additional case, that being where there is a
4353                   common prefix, which gets split out into an EXACT like node
4354                   preceding the TRIE node.
4355
4356                   If x(1..n)==tail then we can do a simple trie, if not we make
4357                   a "jump" trie, such that when we match the appropriate word
4358                   we "jump" to the appropriate tail node. Essentially we turn
4359                   a nested if into a case structure of sorts.
4360
4361                 */
4362
4363                     int made=0;
4364                     if (!re_trie_maxbuff) {
4365                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4366                         if (!SvIOK(re_trie_maxbuff))
4367                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4368                     }
4369                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4370                         regnode *cur;
4371                         regnode *first = (regnode *)NULL;
4372                         regnode *last = (regnode *)NULL;
4373                         regnode *tail = scan;
4374                         U8 trietype = 0;
4375                         U32 count=0;
4376
4377                         /* var tail is used because there may be a TAIL
4378                            regop in the way. Ie, the exacts will point to the
4379                            thing following the TAIL, but the last branch will
4380                            point at the TAIL. So we advance tail. If we
4381                            have nested (?:) we may have to move through several
4382                            tails.
4383                          */
4384
4385                         while ( OP( tail ) == TAIL ) {
4386                             /* this is the TAIL generated by (?:) */
4387                             tail = regnext( tail );
4388                         }
4389
4390
4391                         DEBUG_TRIE_COMPILE_r({
4392                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4393                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
4394                               (int)depth * 2 + 2, "",
4395                               "Looking for TRIE'able sequences. Tail node is: ",
4396                               SvPV_nolen_const( RExC_mysv )
4397                             );
4398                         });
4399
4400                         /*
4401
4402                             Step through the branches
4403                                 cur represents each branch,
4404                                 noper is the first thing to be matched as part
4405                                       of that branch
4406                                 noper_next is the regnext() of that node.
4407
4408                             We normally handle a case like this
4409                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4410                             support building with NOJUMPTRIE, which restricts
4411                             the trie logic to structures like /FOO|BAR/.
4412
4413                             If noper is a trieable nodetype then the branch is
4414                             a possible optimization target. If we are building
4415                             under NOJUMPTRIE then we require that noper_next is
4416                             the same as scan (our current position in the regex
4417                             program).
4418
4419                             Once we have two or more consecutive such branches
4420                             we can create a trie of the EXACT's contents and
4421                             stitch it in place into the program.
4422
4423                             If the sequence represents all of the branches in
4424                             the alternation we replace the entire thing with a
4425                             single TRIE node.
4426
4427                             Otherwise when it is a subsequence we need to
4428                             stitch it in place and replace only the relevant
4429                             branches. This means the first branch has to remain
4430                             as it is used by the alternation logic, and its
4431                             next pointer, and needs to be repointed at the item
4432                             on the branch chain following the last branch we
4433                             have optimized away.
4434
4435                             This could be either a BRANCH, in which case the
4436                             subsequence is internal, or it could be the item
4437                             following the branch sequence in which case the
4438                             subsequence is at the end (which does not
4439                             necessarily mean the first node is the start of the
4440                             alternation).
4441
4442                             TRIE_TYPE(X) is a define which maps the optype to a
4443                             trietype.
4444
4445                                 optype          |  trietype
4446                                 ----------------+-----------
4447                                 NOTHING         | NOTHING
4448                                 EXACT           | EXACT
4449                                 EXACTFU         | EXACTFU
4450                                 EXACTFU_SS      | EXACTFU
4451                                 EXACTFA         | EXACTFA
4452                                 EXACTL          | EXACTL
4453                                 EXACTFLU8       | EXACTFLU8
4454
4455
4456                         */
4457 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4458                        ? NOTHING                                            \
4459                        : ( EXACT == (X) )                                   \
4460                          ? EXACT                                            \
4461                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4462                            ? EXACTFU                                        \
4463                            : ( EXACTFA == (X) )                             \
4464                              ? EXACTFA                                      \
4465                              : ( EXACTL == (X) )                            \
4466                                ? EXACTL                                     \
4467                                : ( EXACTFLU8 == (X) )                        \
4468                                  ? EXACTFLU8                                 \
4469                                  : 0 )
4470
4471                         /* dont use tail as the end marker for this traverse */
4472                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4473                             regnode * const noper = NEXTOPER( cur );
4474                             U8 noper_type = OP( noper );
4475                             U8 noper_trietype = TRIE_TYPE( noper_type );
4476 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4477                             regnode * const noper_next = regnext( noper );
4478                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
4479                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
4480 #endif
4481
4482                             DEBUG_TRIE_COMPILE_r({
4483                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4484                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
4485                                    (int)depth * 2 + 2,"", SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4486
4487                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4488                                 PerlIO_printf( Perl_debug_log, " -> %s",
4489                                     SvPV_nolen_const(RExC_mysv));
4490
4491                                 if ( noper_next ) {
4492                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4493                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
4494                                     SvPV_nolen_const(RExC_mysv));
4495                                 }
4496                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
4497                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4498                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4499                                 );
4500                             });
4501
4502                             /* Is noper a trieable nodetype that can be merged
4503                              * with the current trie (if there is one)? */
4504                             if ( noper_trietype
4505                                   &&
4506                                   (
4507                                         ( noper_trietype == NOTHING)
4508                                         || ( trietype == NOTHING )
4509                                         || ( trietype == noper_trietype )
4510                                   )
4511 #ifdef NOJUMPTRIE
4512                                   && noper_next == tail
4513 #endif
4514                                   && count < U16_MAX)
4515                             {
4516                                 /* Handle mergable triable node Either we are
4517                                  * the first node in a new trieable sequence,
4518                                  * in which case we do some bookkeeping,
4519                                  * otherwise we update the end pointer. */
4520                                 if ( !first ) {
4521                                     first = cur;
4522                                     if ( noper_trietype == NOTHING ) {
4523 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4524                                         regnode * const noper_next = regnext( noper );
4525                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
4526                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4527 #endif
4528
4529                                         if ( noper_next_trietype ) {
4530                                             trietype = noper_next_trietype;
4531                                         } else if (noper_next_type)  {
4532                                             /* a NOTHING regop is 1 regop wide.
4533                                              * We need at least two for a trie
4534                                              * so we can't merge this in */
4535                                             first = NULL;
4536                                         }
4537                                     } else {
4538                                         trietype = noper_trietype;
4539                                     }
4540                                 } else {
4541                                     if ( trietype == NOTHING )
4542                                         trietype = noper_trietype;
4543                                     last = cur;
4544                                 }
4545                                 if (first)
4546                                     count++;
4547                             } /* end handle mergable triable node */
4548                             else {
4549                                 /* handle unmergable node -
4550                                  * noper may either be a triable node which can
4551                                  * not be tried together with the current trie,
4552                                  * or a non triable node */
4553                                 if ( last ) {
4554                                     /* If last is set and trietype is not
4555                                      * NOTHING then we have found at least two
4556                                      * triable branch sequences in a row of a
4557                                      * similar trietype so we can turn them
4558                                      * into a trie. If/when we allow NOTHING to
4559                                      * start a trie sequence this condition
4560                                      * will be required, and it isn't expensive
4561                                      * so we leave it in for now. */
4562                                     if ( trietype && trietype != NOTHING )
4563                                         make_trie( pRExC_state,
4564                                                 startbranch, first, cur, tail,
4565                                                 count, trietype, depth+1 );
4566                                     last = NULL; /* note: we clear/update
4567                                                     first, trietype etc below,
4568                                                     so we dont do it here */
4569                                 }
4570                                 if ( noper_trietype
4571 #ifdef NOJUMPTRIE
4572                                      && noper_next == tail
4573 #endif
4574                                 ){
4575                                     /* noper is triable, so we can start a new
4576                                      * trie sequence */
4577                                     count = 1;
4578                                     first = cur;
4579                                     trietype = noper_trietype;
4580                                 } else if (first) {
4581                                     /* if we already saw a first but the
4582                                      * current node is not triable then we have
4583                                      * to reset the first information. */
4584                                     count = 0;
4585                                     first = NULL;
4586                                     trietype = 0;
4587                                 }
4588                             } /* end handle unmergable node */
4589                         } /* loop over branches */
4590                         DEBUG_TRIE_COMPILE_r({
4591                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4592                             PerlIO_printf( Perl_debug_log,
4593                               "%*s- %s (%d) <SCAN FINISHED>\n",
4594                               (int)depth * 2 + 2,
4595                               "", SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4596
4597                         });
4598                         if ( last && trietype ) {
4599                             if ( trietype != NOTHING ) {
4600                                 /* the last branch of the sequence was part of
4601                                  * a trie, so we have to construct it here
4602                                  * outside of the loop */
4603                                 made= make_trie( pRExC_state, startbranch,
4604                                                  first, scan, tail, count,
4605                                                  trietype, depth+1 );
4606 #ifdef TRIE_STUDY_OPT
4607                                 if ( ((made == MADE_EXACT_TRIE &&
4608                                      startbranch == first)
4609                                      || ( first_non_open == first )) &&
4610                                      depth==0 ) {
4611                                     flags |= SCF_TRIE_RESTUDY;
4612                                     if ( startbranch == first
4613                                          && scan == tail )
4614                                     {
4615                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4616                                     }
4617                                 }
4618 #endif
4619                             } else {
4620                                 /* at this point we know whatever we have is a
4621                                  * NOTHING sequence/branch AND if 'startbranch'
4622                                  * is 'first' then we can turn the whole thing
4623                                  * into a NOTHING
4624                                  */
4625                                 if ( startbranch == first ) {
4626                                     regnode *opt;
4627                                     /* the entire thing is a NOTHING sequence,
4628                                      * something like this: (?:|) So we can
4629                                      * turn it into a plain NOTHING op. */
4630                                     DEBUG_TRIE_COMPILE_r({
4631                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4632                                         PerlIO_printf( Perl_debug_log,
4633                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
4634                                           "", SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4635
4636                                     });
4637                                     OP(startbranch)= NOTHING;
4638                                     NEXT_OFF(startbranch)= tail - startbranch;
4639                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4640                                         OP(opt)= OPTIMIZED;
4641                                 }
4642                             }
4643                         } /* end if ( last) */
4644                     } /* TRIE_MAXBUF is non zero */
4645
4646                 } /* do trie */
4647
4648             }
4649             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4650                 scan = NEXTOPER(NEXTOPER(scan));
4651             } else                      /* single branch is optimized. */
4652                 scan = NEXTOPER(scan);
4653             continue;
4654         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
4655             I32 paren = 0;
4656             regnode *start = NULL;
4657             regnode *end = NULL;
4658             U32 my_recursed_depth= recursed_depth;
4659
4660
4661             if (OP(scan) != SUSPEND) { /* GOSUB/GOSTART */
4662                 /* Do setup, note this code has side effects beyond
4663                  * the rest of this block. Specifically setting
4664                  * RExC_recurse[] must happen at least once during
4665                  * study_chunk(). */
4666                 if (OP(scan) == GOSUB) {
4667                     paren = ARG(scan);
4668                     RExC_recurse[ARG2L(scan)] = scan;
4669                     start = RExC_open_parens[paren-1];
4670                     end   = RExC_close_parens[paren-1];
4671                 } else {
4672                     start = RExC_rxi->program + 1;
4673                     end   = RExC_opend;
4674                 }
4675                 /* NOTE we MUST always execute the above code, even
4676                  * if we do nothing with a GOSUB/GOSTART */
4677                 if (
4678                     ( flags & SCF_IN_DEFINE )
4679                     ||
4680                     (
4681                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4682                         &&
4683                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4684                     )
4685                 ) {
4686                     /* no need to do anything here if we are in a define. */
4687                     /* or we are after some kind of infinite construct
4688                      * so we can skip recursing into this item.
4689                      * Since it is infinite we will not change the maxlen
4690                      * or delta, and if we miss something that might raise
4691                      * the minlen it will merely pessimise a little.
4692                      *
4693                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4694                      * might result in a minlen of 1 and not of 4,
4695                      * but this doesn't make us mismatch, just try a bit
4696                      * harder than we should.
4697                      * */
4698                     scan= regnext(scan);
4699                     continue;
4700                 }
4701
4702                 if (
4703                     !recursed_depth
4704                     ||
4705                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4706                 ) {
4707                     /* it is quite possible that there are more efficient ways
4708                      * to do this. We maintain a bitmap per level of recursion
4709                      * of which patterns we have entered so we can detect if a
4710                      * pattern creates a possible infinite loop. When we
4711                      * recurse down a level we copy the previous levels bitmap
4712                      * down. When we are at recursion level 0 we zero the top
4713                      * level bitmap. It would be nice to implement a different
4714                      * more efficient way of doing this. In particular the top
4715                      * level bitmap may be unnecessary.
4716                      */
4717                     if (!recursed_depth) {
4718                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4719                     } else {
4720                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4721                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4722                              RExC_study_chunk_recursed_bytes, U8);
4723                     }
4724                     /* we havent recursed into this paren yet, so recurse into it */
4725                     DEBUG_STUDYDATA("set:", data,depth);
4726                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4727                     my_recursed_depth= recursed_depth + 1;
4728                 } else {
4729                     DEBUG_STUDYDATA("inf:", data,depth);
4730                     /* some form of infinite recursion, assume infinite length
4731                      * */
4732                     if (flags & SCF_DO_SUBSTR) {
4733                         scan_commit(pRExC_state, data, minlenp, is_inf);
4734                         data->longest = &(data->longest_float);
4735                     }
4736                     is_inf = is_inf_internal = 1;
4737                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4738                         ssc_anything(data->start_class);
4739                     flags &= ~SCF_DO_STCLASS;
4740
4741                     start= NULL; /* reset start so we dont recurse later on. */
4742                 }
4743             } else {
4744                 paren = stopparen;
4745                 start = scan + 2;
4746                 end = regnext(scan);
4747             }
4748             if (start) {
4749                 scan_frame *newframe;
4750                 assert(end);
4751                 if (!RExC_frame_last) {
4752                     Newxz(newframe, 1, scan_frame);
4753                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4754                     RExC_frame_head= newframe;
4755                     RExC_frame_count++;
4756                 } else if (!RExC_frame_last->next_frame) {
4757                     Newxz(newframe,1,scan_frame);
4758                     RExC_frame_last->next_frame= newframe;
4759                     newframe->prev_frame= RExC_frame_last;
4760                     RExC_frame_count++;
4761                 } else {
4762                     newframe= RExC_frame_last->next_frame;
4763                 }
4764                 RExC_frame_last= newframe;
4765
4766                 newframe->next_regnode = regnext(scan);
4767                 newframe->last_regnode = last;
4768                 newframe->stopparen = stopparen;
4769                 newframe->prev_recursed_depth = recursed_depth;
4770                 newframe->this_prev_frame= frame;
4771
4772                 DEBUG_STUDYDATA("frame-new:",data,depth);
4773                 DEBUG_PEEP("fnew", scan, depth);
4774
4775                 frame = newframe;
4776                 scan =  start;
4777                 stopparen = paren;
4778                 last = end;
4779                 depth = depth + 1;
4780                 recursed_depth= my_recursed_depth;
4781
4782                 continue;
4783             }
4784         }
4785         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4786             SSize_t l = STR_LEN(scan);
4787             UV uc;
4788             if (UTF) {
4789                 const U8 * const s = (U8*)STRING(scan);
4790                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4791                 l = utf8_length(s, s + l);
4792             } else {
4793                 uc = *((U8*)STRING(scan));
4794             }
4795             min += l;
4796             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4797                 /* The code below prefers earlier match for fixed
4798                    offset, later match for variable offset.  */
4799                 if (data->last_end == -1) { /* Update the start info. */
4800                     data->last_start_min = data->pos_min;
4801                     data->last_start_max = is_inf
4802                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4803                 }
4804                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4805                 if (UTF)
4806                     SvUTF8_on(data->last_found);
4807                 {
4808                     SV * const sv = data->last_found;
4809                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4810                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4811                     if (mg && mg->mg_len >= 0)
4812                         mg->mg_len += utf8_length((U8*)STRING(scan),
4813                                               (U8*)STRING(scan)+STR_LEN(scan));
4814                 }
4815                 data->last_end = data->pos_min + l;
4816                 data->pos_min += l; /* As in the first entry. */
4817                 data->flags &= ~SF_BEFORE_EOL;
4818             }
4819
4820             /* ANDing the code point leaves at most it, and not in locale, and
4821              * can't match null string */
4822             if (flags & SCF_DO_STCLASS_AND) {
4823                 ssc_cp_and(data->start_class, uc);
4824                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4825                 ssc_clear_locale(data->start_class);
4826             }
4827             else if (flags & SCF_DO_STCLASS_OR) {
4828                 ssc_add_cp(data->start_class, uc);
4829                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4830
4831                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4832                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4833             }
4834             flags &= ~SCF_DO_STCLASS;
4835         }
4836         else if (PL_regkind[OP(scan)] == EXACT) {
4837             /* But OP != EXACT!, so is EXACTFish */
4838             SSize_t l = STR_LEN(scan);
4839             const U8 * s = (U8*)STRING(scan);
4840
4841             /* Search for fixed substrings supports EXACT only. */
4842             if (flags & SCF_DO_SUBSTR) {
4843                 assert(data);
4844                 scan_commit(pRExC_state, data, minlenp, is_inf);
4845             }
4846             if (UTF) {
4847                 l = utf8_length(s, s + l);
4848             }
4849             if (unfolded_multi_char) {
4850                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4851             }
4852             min += l - min_subtract;
4853             assert (min >= 0);
4854             delta += min_subtract;
4855             if (flags & SCF_DO_SUBSTR) {
4856                 data->pos_min += l - min_subtract;
4857                 if (data->pos_min < 0) {
4858                     data->pos_min = 0;
4859                 }
4860                 data->pos_delta += min_subtract;
4861                 if (min_subtract) {
4862                     data->longest = &(data->longest_float);
4863                 }
4864             }
4865
4866             if (flags & SCF_DO_STCLASS) {
4867                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4868
4869                 assert(EXACTF_invlist);
4870                 if (flags & SCF_DO_STCLASS_AND) {
4871                     if (OP(scan) != EXACTFL)
4872                         ssc_clear_locale(data->start_class);
4873                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4874                     ANYOF_POSIXL_ZERO(data->start_class);
4875                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4876                 }
4877                 else {  /* SCF_DO_STCLASS_OR */
4878                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4879                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4880
4881                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4882                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4883                 }
4884                 flags &= ~SCF_DO_STCLASS;
4885                 SvREFCNT_dec(EXACTF_invlist);
4886             }
4887         }
4888         else if (REGNODE_VARIES(OP(scan))) {
4889             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4890             I32 fl = 0, f = flags;
4891             regnode * const oscan = scan;
4892             regnode_ssc this_class;
4893             regnode_ssc *oclass = NULL;
4894             I32 next_is_eval = 0;
4895
4896             switch (PL_regkind[OP(scan)]) {
4897             case WHILEM:                /* End of (?:...)* . */
4898                 scan = NEXTOPER(scan);
4899                 goto finish;
4900             case PLUS:
4901                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4902                     next = NEXTOPER(scan);
4903                     if (OP(next) == EXACT
4904                         || OP(next) == EXACTL
4905                         || (flags & SCF_DO_STCLASS))
4906                     {
4907                         mincount = 1;
4908                         maxcount = REG_INFTY;
4909                         next = regnext(scan);
4910                         scan = NEXTOPER(scan);
4911                         goto do_curly;
4912                     }
4913                 }
4914                 if (flags & SCF_DO_SUBSTR)
4915                     data->pos_min++;
4916                 min++;
4917                 /* FALLTHROUGH */
4918             case STAR:
4919                 if (flags & SCF_DO_STCLASS) {
4920                     mincount = 0;
4921                     maxcount = REG_INFTY;
4922                     next = regnext(scan);
4923                     scan = NEXTOPER(scan);
4924                     goto do_curly;
4925                 }
4926                 if (flags & SCF_DO_SUBSTR) {
4927                     scan_commit(pRExC_state, data, minlenp, is_inf);
4928                     /* Cannot extend fixed substrings */
4929                     data->longest = &(data->longest_float);
4930                 }
4931                 is_inf = is_inf_internal = 1;
4932                 scan = regnext(scan);
4933                 goto optimize_curly_tail;
4934             case CURLY:
4935                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4936                     && (scan->flags == stopparen))
4937                 {
4938                     mincount = 1;
4939                     maxcount = 1;
4940                 } else {
4941                     mincount = ARG1(scan);
4942                     maxcount = ARG2(scan);
4943                 }
4944                 next = regnext(scan);
4945                 if (OP(scan) == CURLYX) {
4946                     I32 lp = (data ? *(data->last_closep) : 0);
4947                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
4948                 }
4949                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4950                 next_is_eval = (OP(scan) == EVAL);
4951               do_curly:
4952                 if (flags & SCF_DO_SUBSTR) {
4953                     if (mincount == 0)
4954                         scan_commit(pRExC_state, data, minlenp, is_inf);
4955                     /* Cannot extend fixed substrings */
4956                     pos_before = data->pos_min;
4957                 }
4958                 if (data) {
4959                     fl = data->flags;
4960                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
4961                     if (is_inf)
4962                         data->flags |= SF_IS_INF;
4963                 }
4964                 if (flags & SCF_DO_STCLASS) {
4965                     ssc_init(pRExC_state, &this_class);
4966                     oclass = data->start_class;
4967                     data->start_class = &this_class;
4968                     f |= SCF_DO_STCLASS_AND;
4969                     f &= ~SCF_DO_STCLASS_OR;
4970                 }
4971                 /* Exclude from super-linear cache processing any {n,m}
4972                    regops for which the combination of input pos and regex
4973                    pos is not enough information to determine if a match
4974                    will be possible.
4975
4976                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
4977                    regex pos at the \s*, the prospects for a match depend not
4978                    only on the input position but also on how many (bar\s*)
4979                    repeats into the {4,8} we are. */
4980                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
4981                     f &= ~SCF_WHILEM_VISITED_POS;
4982
4983                 /* This will finish on WHILEM, setting scan, or on NULL: */
4984                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
4985                                   last, data, stopparen, recursed_depth, NULL,
4986                                   (mincount == 0
4987                                    ? (f & ~SCF_DO_SUBSTR)
4988                                    : f)
4989                                   ,depth+1);
4990
4991                 if (flags & SCF_DO_STCLASS)
4992                     data->start_class = oclass;
4993                 if (mincount == 0 || minnext == 0) {
4994                     if (flags & SCF_DO_STCLASS_OR) {
4995                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4996                     }
4997                     else if (flags & SCF_DO_STCLASS_AND) {
4998                         /* Switch to OR mode: cache the old value of
4999                          * data->start_class */
5000                         INIT_AND_WITHP;
5001                         StructCopy(data->start_class, and_withp, regnode_ssc);
5002                         flags &= ~SCF_DO_STCLASS_AND;
5003                         StructCopy(&this_class, data->start_class, regnode_ssc);
5004                         flags |= SCF_DO_STCLASS_OR;
5005                         ANYOF_FLAGS(data->start_class)
5006                                                 |= SSC_MATCHES_EMPTY_STRING;
5007                     }
5008                 } else {                /* Non-zero len */
5009                     if (flags & SCF_DO_STCLASS_OR) {
5010                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5011                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5012                     }
5013                     else if (flags & SCF_DO_STCLASS_AND)
5014                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5015                     flags &= ~SCF_DO_STCLASS;
5016                 }
5017                 if (!scan)              /* It was not CURLYX, but CURLY. */
5018                     scan = next;
5019                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
5020                     /* ? quantifier ok, except for (?{ ... }) */
5021                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5022                     && (minnext == 0) && (deltanext == 0)
5023                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5024                     && maxcount <= REG_INFTY/3) /* Complement check for big
5025                                                    count */
5026                 {
5027                     /* Fatal warnings may leak the regexp without this: */
5028                     SAVEFREESV(RExC_rx_sv);
5029                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5030                         "Quantifier unexpected on zero-length expression "
5031                         "in regex m/%"UTF8f"/",
5032                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5033                                   RExC_precomp));
5034                     (void)ReREFCNT_inc(RExC_rx_sv);
5035                 }
5036
5037                 min += minnext * mincount;
5038                 is_inf_internal |= deltanext == SSize_t_MAX
5039                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5040                 is_inf |= is_inf_internal;
5041                 if (is_inf) {
5042                     delta = SSize_t_MAX;
5043                 } else {
5044                     delta += (minnext + deltanext) * maxcount
5045                              - minnext * mincount;
5046                 }
5047                 /* Try powerful optimization CURLYX => CURLYN. */
5048                 if (  OP(oscan) == CURLYX && data
5049                       && data->flags & SF_IN_PAR
5050                       && !(data->flags & SF_HAS_EVAL)
5051                       && !deltanext && minnext == 1 ) {
5052                     /* Try to optimize to CURLYN.  */
5053                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5054                     regnode * const nxt1 = nxt;
5055 #ifdef DEBUGGING
5056                     regnode *nxt2;
5057 #endif
5058
5059                     /* Skip open. */
5060                     nxt = regnext(nxt);
5061                     if (!REGNODE_SIMPLE(OP(nxt))
5062                         && !(PL_regkind[OP(nxt)] == EXACT
5063                              && STR_LEN(nxt) == 1))
5064                         goto nogo;
5065 #ifdef DEBUGGING
5066                     nxt2 = nxt;
5067 #endif
5068                     nxt = regnext(nxt);
5069                     if (OP(nxt) != CLOSE)
5070                         goto nogo;
5071                     if (RExC_open_parens) {
5072                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
5073                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
5074                     }
5075                     /* Now we know that nxt2 is the only contents: */
5076                     oscan->flags = (U8)ARG(nxt);
5077                     OP(oscan) = CURLYN;
5078                     OP(nxt1) = NOTHING; /* was OPEN. */
5079
5080 #ifdef DEBUGGING
5081                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5082                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5083                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5084                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5085                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5086                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5087 #endif
5088                 }
5089               nogo:
5090
5091                 /* Try optimization CURLYX => CURLYM. */
5092                 if (  OP(oscan) == CURLYX && data
5093                       && !(data->flags & SF_HAS_PAR)
5094                       && !(data->flags & SF_HAS_EVAL)
5095                       && !deltanext     /* atom is fixed width */
5096                       && minnext != 0   /* CURLYM can't handle zero width */
5097
5098                          /* Nor characters whose fold at run-time may be
5099                           * multi-character */
5100                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5101                 ) {
5102                     /* XXXX How to optimize if data == 0? */
5103                     /* Optimize to a simpler form.  */
5104                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5105                     regnode *nxt2;
5106
5107                     OP(oscan) = CURLYM;
5108                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5109                             && (OP(nxt2) != WHILEM))
5110                         nxt = nxt2;
5111                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5112                     /* Need to optimize away parenths. */
5113                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5114                         /* Set the parenth number.  */
5115                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5116
5117                         oscan->flags = (U8)ARG(nxt);
5118                         if (RExC_open_parens) {
5119                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
5120                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
5121                         }
5122                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5123                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5124
5125 #ifdef DEBUGGING
5126                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5127                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5128                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5129                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5130 #endif
5131 #if 0
5132                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5133                             regnode *nnxt = regnext(nxt1);
5134                             if (nnxt == nxt) {
5135                                 if (reg_off_by_arg[OP(nxt1)])
5136                                     ARG_SET(nxt1, nxt2 - nxt1);
5137                                 else if (nxt2 - nxt1 < U16_MAX)
5138                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5139                                 else
5140                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5141                             }
5142                             nxt1 = nnxt;
5143                         }
5144 #endif
5145                         /* Optimize again: */
5146                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5147                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5148                     }
5149                     else
5150                         oscan->flags = 0;
5151                 }
5152                 else if ((OP(oscan) == CURLYX)
5153                          && (flags & SCF_WHILEM_VISITED_POS)
5154                          /* See the comment on a similar expression above.
5155                             However, this time it's not a subexpression
5156                             we care about, but the expression itself. */
5157                          && (maxcount == REG_INFTY)
5158                          && data && ++data->whilem_c < 16) {
5159                     /* This stays as CURLYX, we can put the count/of pair. */
5160                     /* Find WHILEM (as in regexec.c) */
5161                     regnode *nxt = oscan + NEXT_OFF(oscan);
5162
5163                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5164                         nxt += ARG(nxt);
5165                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
5166                         | (RExC_whilem_seen << 4)); /* On WHILEM */
5167                 }
5168                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5169                     pars++;
5170                 if (flags & SCF_DO_SUBSTR) {
5171                     SV *last_str = NULL;
5172                     STRLEN last_chrs = 0;
5173                     int counted = mincount != 0;
5174
5175                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5176                                                                   string. */
5177                         SSize_t b = pos_before >= data->last_start_min
5178                             ? pos_before : data->last_start_min;
5179                         STRLEN l;
5180                         const char * const s = SvPV_const(data->last_found, l);
5181                         SSize_t old = b - data->last_start_min;
5182
5183                         if (UTF)
5184                             old = utf8_hop((U8*)s, old) - (U8*)s;
5185                         l -= old;
5186                         /* Get the added string: */
5187                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5188                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5189                                             (U8*)(s + old + l)) : l;
5190                         if (deltanext == 0 && pos_before == b) {
5191                             /* What was added is a constant string */
5192                             if (mincount > 1) {
5193
5194                                 SvGROW(last_str, (mincount * l) + 1);
5195                                 repeatcpy(SvPVX(last_str) + l,
5196                                           SvPVX_const(last_str), l,
5197                                           mincount - 1);
5198                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5199                                 /* Add additional parts. */
5200                                 SvCUR_set(data->last_found,
5201                                           SvCUR(data->last_found) - l);
5202                                 sv_catsv(data->last_found, last_str);
5203                                 {
5204                                     SV * sv = data->last_found;
5205                                     MAGIC *mg =
5206                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5207                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5208                                     if (mg && mg->mg_len >= 0)
5209                                         mg->mg_len += last_chrs * (mincount-1);
5210                                 }
5211                                 last_chrs *= mincount;
5212                                 data->last_end += l * (mincount - 1);
5213                             }
5214                         } else {
5215                             /* start offset must point into the last copy */
5216                             data->last_start_min += minnext * (mincount - 1);
5217                             data->last_start_max =
5218                               is_inf
5219                                ? SSize_t_MAX
5220                                : data->last_start_max +
5221                                  (maxcount - 1) * (minnext + data->pos_delta);
5222                         }
5223                     }
5224                     /* It is counted once already... */
5225                     data->pos_min += minnext * (mincount - counted);
5226 #if 0
5227 PerlIO_printf(Perl_debug_log, "counted=%"UVuf" deltanext=%"UVuf
5228                               " SSize_t_MAX=%"UVuf" minnext=%"UVuf
5229                               " maxcount=%"UVuf" mincount=%"UVuf"\n",
5230     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5231     (UV)mincount);
5232 if (deltanext != SSize_t_MAX)
5233 PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n",
5234     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5235           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5236 #endif
5237                     if (deltanext == SSize_t_MAX
5238                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5239                         data->pos_delta = SSize_t_MAX;
5240                     else
5241                         data->pos_delta += - counted * deltanext +
5242                         (minnext + deltanext) * maxcount - minnext * mincount;
5243                     if (mincount != maxcount) {
5244                          /* Cannot extend fixed substrings found inside
5245                             the group.  */
5246                         scan_commit(pRExC_state, data, minlenp, is_inf);
5247                         if (mincount && last_str) {
5248                             SV * const sv = data->last_found;
5249                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5250                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5251
5252                             if (mg)
5253                                 mg->mg_len = -1;
5254                             sv_setsv(sv, last_str);
5255                             data->last_end = data->pos_min;
5256                             data->last_start_min = data->pos_min - last_chrs;
5257                             data->last_start_max = is_inf
5258                                 ? SSize_t_MAX
5259                                 : data->pos_min + data->pos_delta - last_chrs;
5260                         }
5261                         data->longest = &(data->longest_float);
5262                     }
5263                     SvREFCNT_dec(last_str);
5264                 }
5265                 if (data && (fl & SF_HAS_EVAL))
5266                     data->flags |= SF_HAS_EVAL;
5267               optimize_curly_tail:
5268                 if (OP(oscan) != CURLYX) {
5269                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5270                            && NEXT_OFF(next))
5271                         NEXT_OFF(oscan) += NEXT_OFF(next);
5272                 }
5273                 continue;
5274
5275             default:
5276 #ifdef DEBUGGING
5277                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5278                                                                     OP(scan));
5279 #endif
5280             case REF:
5281             case CLUMP:
5282                 if (flags & SCF_DO_SUBSTR) {
5283                     /* Cannot expect anything... */
5284                     scan_commit(pRExC_state, data, minlenp, is_inf);
5285                     data->longest = &(data->longest_float);
5286                 }
5287                 is_inf = is_inf_internal = 1;
5288                 if (flags & SCF_DO_STCLASS_OR) {
5289                     if (OP(scan) == CLUMP) {
5290                         /* Actually is any start char, but very few code points
5291                          * aren't start characters */
5292                         ssc_match_all_cp(data->start_class);
5293                     }
5294                     else {
5295                         ssc_anything(data->start_class);
5296                     }
5297                 }
5298                 flags &= ~SCF_DO_STCLASS;
5299                 break;
5300             }
5301         }
5302         else if (OP(scan) == LNBREAK) {
5303             if (flags & SCF_DO_STCLASS) {
5304                 if (flags & SCF_DO_STCLASS_AND) {
5305                     ssc_intersection(data->start_class,
5306                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5307                     ssc_clear_locale(data->start_class);
5308                     ANYOF_FLAGS(data->start_class)
5309                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5310                 }
5311                 else if (flags & SCF_DO_STCLASS_OR) {
5312                     ssc_union(data->start_class,
5313                               PL_XPosix_ptrs[_CC_VERTSPACE],
5314                               FALSE);
5315                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5316
5317                     /* See commit msg for
5318                      * 749e076fceedeb708a624933726e7989f2302f6a */
5319                     ANYOF_FLAGS(data->start_class)
5320                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5321                 }
5322                 flags &= ~SCF_DO_STCLASS;
5323             }
5324             min++;
5325             if (delta != SSize_t_MAX)
5326                 delta++;    /* Because of the 2 char string cr-lf */
5327             if (flags & SCF_DO_SUBSTR) {
5328                 /* Cannot expect anything... */
5329                 scan_commit(pRExC_state, data, minlenp, is_inf);
5330                 data->pos_min += 1;
5331                 data->pos_delta += 1;
5332                 data->longest = &(data->longest_float);
5333             }
5334         }
5335         else if (REGNODE_SIMPLE(OP(scan))) {
5336
5337             if (flags & SCF_DO_SUBSTR) {
5338                 scan_commit(pRExC_state, data, minlenp, is_inf);
5339                 data->pos_min++;
5340             }
5341             min++;
5342             if (flags & SCF_DO_STCLASS) {
5343                 bool invert = 0;
5344                 SV* my_invlist = NULL;
5345                 U8 namedclass;
5346
5347                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5348                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5349
5350                 /* Some of the logic below assumes that switching
5351                    locale on will only add false positives. */
5352                 switch (OP(scan)) {
5353
5354                 default:
5355 #ifdef DEBUGGING
5356                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5357                                                                      OP(scan));
5358 #endif
5359                 case SANY:
5360                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5361                         ssc_match_all_cp(data->start_class);
5362                     break;
5363
5364                 case REG_ANY:
5365                     {
5366                         SV* REG_ANY_invlist = _new_invlist(2);
5367                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5368                                                             '\n');
5369                         if (flags & SCF_DO_STCLASS_OR) {
5370                             ssc_union(data->start_class,
5371                                       REG_ANY_invlist,
5372                                       TRUE /* TRUE => invert, hence all but \n
5373                                             */
5374                                       );
5375                         }
5376                         else if (flags & SCF_DO_STCLASS_AND) {
5377                             ssc_intersection(data->start_class,
5378                                              REG_ANY_invlist,
5379                                              TRUE  /* TRUE => invert */
5380                                              );
5381                             ssc_clear_locale(data->start_class);
5382                         }
5383                         SvREFCNT_dec_NN(REG_ANY_invlist);
5384                     }
5385                     break;
5386
5387                 case ANYOFD:
5388                 case ANYOFL:
5389                 case ANYOF:
5390                     if (flags & SCF_DO_STCLASS_AND)
5391                         ssc_and(pRExC_state, data->start_class,
5392                                 (regnode_charclass *) scan);
5393                     else
5394                         ssc_or(pRExC_state, data->start_class,
5395                                                           (regnode_charclass *) scan);
5396                     break;
5397
5398                 case NPOSIXL:
5399                     invert = 1;
5400                     /* FALLTHROUGH */
5401
5402                 case POSIXL:
5403                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5404                     if (flags & SCF_DO_STCLASS_AND) {
5405                         bool was_there = cBOOL(
5406                                           ANYOF_POSIXL_TEST(data->start_class,
5407                                                                  namedclass));
5408                         ANYOF_POSIXL_ZERO(data->start_class);
5409                         if (was_there) {    /* Do an AND */
5410                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5411                         }
5412                         /* No individual code points can now match */
5413                         data->start_class->invlist
5414                                                 = sv_2mortal(_new_invlist(0));
5415                     }
5416                     else {
5417                         int complement = namedclass + ((invert) ? -1 : 1);
5418
5419                         assert(flags & SCF_DO_STCLASS_OR);
5420
5421                         /* If the complement of this class was already there,
5422                          * the result is that they match all code points,
5423                          * (\d + \D == everything).  Remove the classes from
5424                          * future consideration.  Locale is not relevant in
5425                          * this case */
5426                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5427                             ssc_match_all_cp(data->start_class);
5428                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5429                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5430                         }
5431                         else {  /* The usual case; just add this class to the
5432                                    existing set */
5433                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5434                         }
5435                     }
5436                     break;
5437
5438                 case NPOSIXA:   /* For these, we always know the exact set of
5439                                    what's matched */
5440                     invert = 1;
5441                     /* FALLTHROUGH */
5442                 case POSIXA:
5443                     if (FLAGS(scan) == _CC_ASCII) {
5444                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5445                     }
5446                     else {
5447                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5448                                               PL_XPosix_ptrs[_CC_ASCII],
5449                                               &my_invlist);
5450                     }
5451                     goto join_posix;
5452
5453                 case NPOSIXD:
5454                 case NPOSIXU:
5455                     invert = 1;
5456                     /* FALLTHROUGH */
5457                 case POSIXD:
5458                 case POSIXU:
5459                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5460
5461                     /* NPOSIXD matches all upper Latin1 code points unless the
5462                      * target string being matched is UTF-8, which is
5463                      * unknowable until match time.  Since we are going to
5464                      * invert, we want to get rid of all of them so that the
5465                      * inversion will match all */
5466                     if (OP(scan) == NPOSIXD) {
5467                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5468                                           &my_invlist);
5469                     }
5470
5471                   join_posix:
5472
5473                     if (flags & SCF_DO_STCLASS_AND) {
5474                         ssc_intersection(data->start_class, my_invlist, invert);
5475                         ssc_clear_locale(data->start_class);
5476                     }
5477                     else {
5478                         assert(flags & SCF_DO_STCLASS_OR);
5479                         ssc_union(data->start_class, my_invlist, invert);
5480                     }
5481                     SvREFCNT_dec(my_invlist);
5482                 }
5483                 if (flags & SCF_DO_STCLASS_OR)
5484                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5485                 flags &= ~SCF_DO_STCLASS;
5486             }
5487         }
5488         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5489             data->flags |= (OP(scan) == MEOL
5490                             ? SF_BEFORE_MEOL
5491                             : SF_BEFORE_SEOL);
5492             scan_commit(pRExC_state, data, minlenp, is_inf);
5493
5494         }
5495         else if (  PL_regkind[OP(scan)] == BRANCHJ
5496                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5497                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5498                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5499         {
5500             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5501                 || OP(scan) == UNLESSM )
5502             {
5503                 /* Negative Lookahead/lookbehind
5504                    In this case we can't do fixed string optimisation.
5505                 */
5506
5507                 SSize_t deltanext, minnext, fake = 0;
5508                 regnode *nscan;
5509                 regnode_ssc intrnl;
5510                 int f = 0;
5511
5512                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5513                 if (data) {
5514                     data_fake.whilem_c = data->whilem_c;
5515                     data_fake.last_closep = data->last_closep;
5516                 }
5517                 else
5518                     data_fake.last_closep = &fake;
5519                 data_fake.pos_delta = delta;
5520                 if ( flags & SCF_DO_STCLASS && !scan->flags
5521                      && OP(scan) == IFMATCH ) { /* Lookahead */
5522                     ssc_init(pRExC_state, &intrnl);
5523                     data_fake.start_class = &intrnl;
5524                     f |= SCF_DO_STCLASS_AND;
5525                 }
5526                 if (flags & SCF_WHILEM_VISITED_POS)
5527                     f |= SCF_WHILEM_VISITED_POS;
5528                 next = regnext(scan);
5529                 nscan = NEXTOPER(NEXTOPER(scan));
5530                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5531                                       last, &data_fake, stopparen,
5532                                       recursed_depth, NULL, f, depth+1);
5533                 if (scan->flags) {
5534                     if (deltanext) {
5535                         FAIL("Variable length lookbehind not implemented");
5536                     }
5537                     else if (minnext > (I32)U8_MAX) {
5538                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5539                               (UV)U8_MAX);
5540                     }
5541                     scan->flags = (U8)minnext;
5542                 }
5543                 if (data) {
5544                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5545                         pars++;
5546                     if (data_fake.flags & SF_HAS_EVAL)
5547                         data->flags |= SF_HAS_EVAL;
5548                     data->whilem_c = data_fake.whilem_c;
5549                 }
5550                 if (f & SCF_DO_STCLASS_AND) {
5551                     if (flags & SCF_DO_STCLASS_OR) {
5552                         /* OR before, AND after: ideally we would recurse with
5553                          * data_fake to get the AND applied by study of the
5554                          * remainder of the pattern, and then derecurse;
5555                          * *** HACK *** for now just treat as "no information".
5556                          * See [perl #56690].
5557                          */
5558                         ssc_init(pRExC_state, data->start_class);
5559                     }  else {
5560                         /* AND before and after: combine and continue.  These
5561                          * assertions are zero-length, so can match an EMPTY
5562                          * string */
5563                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5564                         ANYOF_FLAGS(data->start_class)
5565                                                    |= SSC_MATCHES_EMPTY_STRING;
5566                     }
5567                 }
5568             }
5569 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5570             else {
5571                 /* Positive Lookahead/lookbehind
5572                    In this case we can do fixed string optimisation,
5573                    but we must be careful about it. Note in the case of
5574                    lookbehind the positions will be offset by the minimum
5575                    length of the pattern, something we won't know about
5576                    until after the recurse.
5577                 */
5578                 SSize_t deltanext, fake = 0;
5579                 regnode *nscan;
5580                 regnode_ssc intrnl;
5581                 int f = 0;
5582                 /* We use SAVEFREEPV so that when the full compile
5583                     is finished perl will clean up the allocated
5584                     minlens when it's all done. This way we don't
5585                     have to worry about freeing them when we know
5586                     they wont be used, which would be a pain.
5587                  */
5588                 SSize_t *minnextp;
5589                 Newx( minnextp, 1, SSize_t );
5590                 SAVEFREEPV(minnextp);
5591
5592                 if (data) {
5593                     StructCopy(data, &data_fake, scan_data_t);
5594                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5595                         f |= SCF_DO_SUBSTR;
5596                         if (scan->flags)
5597                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5598                         data_fake.last_found=newSVsv(data->last_found);
5599                     }
5600                 }
5601                 else
5602                     data_fake.last_closep = &fake;
5603                 data_fake.flags = 0;
5604                 data_fake.pos_delta = delta;
5605                 if (is_inf)
5606                     data_fake.flags |= SF_IS_INF;
5607                 if ( flags & SCF_DO_STCLASS && !scan->flags
5608                      && OP(scan) == IFMATCH ) { /* Lookahead */
5609                     ssc_init(pRExC_state, &intrnl);
5610                     data_fake.start_class = &intrnl;
5611                     f |= SCF_DO_STCLASS_AND;
5612                 }
5613                 if (flags & SCF_WHILEM_VISITED_POS)
5614                     f |= SCF_WHILEM_VISITED_POS;
5615                 next = regnext(scan);
5616                 nscan = NEXTOPER(NEXTOPER(scan));
5617
5618                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5619                                         &deltanext, last, &data_fake,
5620                                         stopparen, recursed_depth, NULL,
5621                                         f,depth+1);
5622                 if (scan->flags) {
5623                     if (deltanext) {
5624                         FAIL("Variable length lookbehind not implemented");
5625                     }
5626                     else if (*minnextp > (I32)U8_MAX) {
5627                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5628                               (UV)U8_MAX);
5629                     }
5630                     scan->flags = (U8)*minnextp;
5631                 }
5632
5633                 *minnextp += min;
5634
5635                 if (f & SCF_DO_STCLASS_AND) {
5636                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5637                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5638                 }
5639                 if (data) {
5640                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5641                         pars++;
5642                     if (data_fake.flags & SF_HAS_EVAL)
5643                         data->flags |= SF_HAS_EVAL;
5644                     data->whilem_c = data_fake.whilem_c;
5645                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5646                         if (RExC_rx->minlen<*minnextp)
5647                             RExC_rx->minlen=*minnextp;
5648                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5649                         SvREFCNT_dec_NN(data_fake.last_found);
5650
5651                         if ( data_fake.minlen_fixed != minlenp )
5652                         {
5653                             data->offset_fixed= data_fake.offset_fixed;
5654                             data->minlen_fixed= data_fake.minlen_fixed;
5655                             data->lookbehind_fixed+= scan->flags;
5656                         }
5657                         if ( data_fake.minlen_float != minlenp )
5658                         {
5659                             data->minlen_float= data_fake.minlen_float;
5660                             data->offset_float_min=data_fake.offset_float_min;
5661                             data->offset_float_max=data_fake.offset_float_max;
5662                             data->lookbehind_float+= scan->flags;
5663                         }
5664                     }
5665                 }
5666             }
5667 #endif
5668         }
5669         else if (OP(scan) == OPEN) {
5670             if (stopparen != (I32)ARG(scan))
5671                 pars++;
5672         }
5673         else if (OP(scan) == CLOSE) {
5674             if (stopparen == (I32)ARG(scan)) {
5675                 break;
5676             }
5677             if ((I32)ARG(scan) == is_par) {
5678                 next = regnext(scan);
5679
5680                 if ( next && (OP(next) != WHILEM) && next < last)
5681                     is_par = 0;         /* Disable optimization */
5682             }
5683             if (data)
5684                 *(data->last_closep) = ARG(scan);
5685         }
5686         else if (OP(scan) == EVAL) {
5687                 if (data)
5688                     data->flags |= SF_HAS_EVAL;
5689         }
5690         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5691             if (flags & SCF_DO_SUBSTR) {
5692                 scan_commit(pRExC_state, data, minlenp, is_inf);
5693                 flags &= ~SCF_DO_SUBSTR;
5694             }
5695             if (data && OP(scan)==ACCEPT) {
5696                 data->flags |= SCF_SEEN_ACCEPT;
5697                 if (stopmin > min)
5698                     stopmin = min;
5699             }
5700         }
5701         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5702         {
5703                 if (flags & SCF_DO_SUBSTR) {
5704                     scan_commit(pRExC_state, data, minlenp, is_inf);
5705                     data->longest = &(data->longest_float);
5706                 }
5707                 is_inf = is_inf_internal = 1;
5708                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5709                     ssc_anything(data->start_class);
5710                 flags &= ~SCF_DO_STCLASS;
5711         }
5712         else if (OP(scan) == GPOS) {
5713             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5714                 !(delta || is_inf || (data && data->pos_delta)))
5715             {
5716                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5717                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5718                 if (RExC_rx->gofs < (STRLEN)min)
5719                     RExC_rx->gofs = min;
5720             } else {
5721                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5722                 RExC_rx->gofs = 0;
5723             }
5724         }
5725 #ifdef TRIE_STUDY_OPT
5726 #ifdef FULL_TRIE_STUDY
5727         else if (PL_regkind[OP(scan)] == TRIE) {
5728             /* NOTE - There is similar code to this block above for handling
5729                BRANCH nodes on the initial study.  If you change stuff here
5730                check there too. */
5731             regnode *trie_node= scan;
5732             regnode *tail= regnext(scan);
5733             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5734             SSize_t max1 = 0, min1 = SSize_t_MAX;
5735             regnode_ssc accum;
5736
5737             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5738                 /* Cannot merge strings after this. */
5739                 scan_commit(pRExC_state, data, minlenp, is_inf);
5740             }
5741             if (flags & SCF_DO_STCLASS)
5742                 ssc_init_zero(pRExC_state, &accum);
5743
5744             if (!trie->jump) {
5745                 min1= trie->minlen;
5746                 max1= trie->maxlen;
5747             } else {
5748                 const regnode *nextbranch= NULL;
5749                 U32 word;
5750
5751                 for ( word=1 ; word <= trie->wordcount ; word++)
5752                 {
5753                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5754                     regnode_ssc this_class;
5755
5756                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5757                     if (data) {
5758                         data_fake.whilem_c = data->whilem_c;
5759                         data_fake.last_closep = data->last_closep;
5760                     }
5761                     else
5762                         data_fake.last_closep = &fake;
5763                     data_fake.pos_delta = delta;
5764                     if (flags & SCF_DO_STCLASS) {
5765                         ssc_init(pRExC_state, &this_class);
5766                         data_fake.start_class = &this_class;
5767                         f = SCF_DO_STCLASS_AND;
5768                     }
5769                     if (flags & SCF_WHILEM_VISITED_POS)
5770                         f |= SCF_WHILEM_VISITED_POS;
5771
5772                     if (trie->jump[word]) {
5773                         if (!nextbranch)
5774                             nextbranch = trie_node + trie->jump[0];
5775                         scan= trie_node + trie->jump[word];
5776                         /* We go from the jump point to the branch that follows
5777                            it. Note this means we need the vestigal unused
5778                            branches even though they arent otherwise used. */
5779                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5780                             &deltanext, (regnode *)nextbranch, &data_fake,
5781                             stopparen, recursed_depth, NULL, f,depth+1);
5782                     }
5783                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5784                         nextbranch= regnext((regnode*)nextbranch);
5785
5786                     if (min1 > (SSize_t)(minnext + trie->minlen))
5787                         min1 = minnext + trie->minlen;
5788                     if (deltanext == SSize_t_MAX) {
5789                         is_inf = is_inf_internal = 1;
5790                         max1 = SSize_t_MAX;
5791                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5792                         max1 = minnext + deltanext + trie->maxlen;
5793
5794                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5795                         pars++;
5796                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5797                         if ( stopmin > min + min1)
5798                             stopmin = min + min1;
5799                         flags &= ~SCF_DO_SUBSTR;
5800                         if (data)
5801                             data->flags |= SCF_SEEN_ACCEPT;
5802                     }
5803                     if (data) {
5804                         if (data_fake.flags & SF_HAS_EVAL)
5805                             data->flags |= SF_HAS_EVAL;
5806                         data->whilem_c = data_fake.whilem_c;
5807                     }
5808                     if (flags & SCF_DO_STCLASS)
5809                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5810                 }
5811             }
5812             if (flags & SCF_DO_SUBSTR) {
5813                 data->pos_min += min1;
5814                 data->pos_delta += max1 - min1;
5815                 if (max1 != min1 || is_inf)
5816                     data->longest = &(data->longest_float);
5817             }
5818             min += min1;
5819             if (delta != SSize_t_MAX)
5820                 delta += max1 - min1;
5821             if (flags & SCF_DO_STCLASS_OR) {
5822                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5823                 if (min1) {
5824                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5825                     flags &= ~SCF_DO_STCLASS;
5826                 }
5827             }
5828             else if (flags & SCF_DO_STCLASS_AND) {
5829                 if (min1) {
5830                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5831                     flags &= ~SCF_DO_STCLASS;
5832                 }
5833                 else {
5834                     /* Switch to OR mode: cache the old value of
5835                      * data->start_class */
5836                     INIT_AND_WITHP;
5837                     StructCopy(data->start_class, and_withp, regnode_ssc);
5838                     flags &= ~SCF_DO_STCLASS_AND;
5839                     StructCopy(&accum, data->start_class, regnode_ssc);
5840                     flags |= SCF_DO_STCLASS_OR;
5841                 }
5842             }
5843             scan= tail;
5844             continue;
5845         }
5846 #else
5847         else if (PL_regkind[OP(scan)] == TRIE) {
5848             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5849             U8*bang=NULL;
5850
5851             min += trie->minlen;
5852             delta += (trie->maxlen - trie->minlen);
5853             flags &= ~SCF_DO_STCLASS; /* xxx */
5854             if (flags & SCF_DO_SUBSTR) {
5855                 /* Cannot expect anything... */
5856                 scan_commit(pRExC_state, data, minlenp, is_inf);
5857                 data->pos_min += trie->minlen;
5858                 data->pos_delta += (trie->maxlen - trie->minlen);
5859                 if (trie->maxlen != trie->minlen)
5860                     data->longest = &(data->longest_float);
5861             }
5862             if (trie->jump) /* no more substrings -- for now /grr*/
5863                flags &= ~SCF_DO_SUBSTR;
5864         }
5865 #endif /* old or new */
5866 #endif /* TRIE_STUDY_OPT */
5867
5868         /* Else: zero-length, ignore. */
5869         scan = regnext(scan);
5870     }
5871     /* If we are exiting a recursion we can unset its recursed bit
5872      * and allow ourselves to enter it again - no danger of an
5873      * infinite loop there.
5874     if (stopparen > -1 && recursed) {
5875         DEBUG_STUDYDATA("unset:", data,depth);
5876         PAREN_UNSET( recursed, stopparen);
5877     }
5878     */
5879     if (frame) {
5880         depth = depth - 1;
5881
5882         DEBUG_STUDYDATA("frame-end:",data,depth);
5883         DEBUG_PEEP("fend", scan, depth);
5884
5885         /* restore previous context */
5886         last = frame->last_regnode;
5887         scan = frame->next_regnode;
5888         stopparen = frame->stopparen;
5889         recursed_depth = frame->prev_recursed_depth;
5890
5891         RExC_frame_last = frame->prev_frame;
5892         frame = frame->this_prev_frame;
5893         goto fake_study_recurse;
5894     }
5895
5896   finish:
5897     assert(!frame);
5898     DEBUG_STUDYDATA("pre-fin:",data,depth);
5899
5900     *scanp = scan;
5901     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5902
5903     if (flags & SCF_DO_SUBSTR && is_inf)
5904         data->pos_delta = SSize_t_MAX - data->pos_min;
5905     if (is_par > (I32)U8_MAX)
5906         is_par = 0;
5907     if (is_par && pars==1 && data) {
5908         data->flags |= SF_IN_PAR;
5909         data->flags &= ~SF_HAS_PAR;
5910     }
5911     else if (pars && data) {
5912         data->flags |= SF_HAS_PAR;
5913         data->flags &= ~SF_IN_PAR;
5914     }
5915     if (flags & SCF_DO_STCLASS_OR)
5916         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5917     if (flags & SCF_TRIE_RESTUDY)
5918         data->flags |=  SCF_TRIE_RESTUDY;
5919
5920     DEBUG_STUDYDATA("post-fin:",data,depth);
5921
5922     {
5923         SSize_t final_minlen= min < stopmin ? min : stopmin;
5924
5925         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
5926             if (final_minlen > SSize_t_MAX - delta)
5927                 RExC_maxlen = SSize_t_MAX;
5928             else if (RExC_maxlen < final_minlen + delta)
5929                 RExC_maxlen = final_minlen + delta;
5930         }
5931         return final_minlen;
5932     }
5933     NOT_REACHED; /* NOTREACHED */
5934 }
5935
5936 STATIC U32
5937 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5938 {
5939     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5940
5941     PERL_ARGS_ASSERT_ADD_DATA;
5942
5943     Renewc(RExC_rxi->data,
5944            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
5945            char, struct reg_data);
5946     if(count)
5947         Renew(RExC_rxi->data->what, count + n, U8);
5948     else
5949         Newx(RExC_rxi->data->what, n, U8);
5950     RExC_rxi->data->count = count + n;
5951     Copy(s, RExC_rxi->data->what + count, n, U8);
5952     return count;
5953 }
5954
5955 /*XXX: todo make this not included in a non debugging perl, but appears to be
5956  * used anyway there, in 'use re' */
5957 #ifndef PERL_IN_XSUB_RE
5958 void
5959 Perl_reginitcolors(pTHX)
5960 {
5961     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
5962     if (s) {
5963         char *t = savepv(s);
5964         int i = 0;
5965         PL_colors[0] = t;
5966         while (++i < 6) {
5967             t = strchr(t, '\t');
5968             if (t) {
5969                 *t = '\0';
5970                 PL_colors[i] = ++t;
5971             }
5972             else
5973                 PL_colors[i] = t = (char *)"";
5974         }
5975     } else {
5976         int i = 0;
5977         while (i < 6)
5978             PL_colors[i++] = (char *)"";
5979     }
5980     PL_colorset = 1;
5981 }
5982 #endif
5983
5984
5985 #ifdef TRIE_STUDY_OPT
5986 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
5987     STMT_START {                                            \
5988         if (                                                \
5989               (data.flags & SCF_TRIE_RESTUDY)               \
5990               && ! restudied++                              \
5991         ) {                                                 \
5992             dOsomething;                                    \
5993             goto reStudy;                                   \
5994         }                                                   \
5995     } STMT_END
5996 #else
5997 #define CHECK_RESTUDY_GOTO_butfirst
5998 #endif
5999
6000 /*
6001  * pregcomp - compile a regular expression into internal code
6002  *
6003  * Decides which engine's compiler to call based on the hint currently in
6004  * scope
6005  */
6006
6007 #ifndef PERL_IN_XSUB_RE
6008
6009 /* return the currently in-scope regex engine (or the default if none)  */
6010
6011 regexp_engine const *
6012 Perl_current_re_engine(pTHX)
6013 {
6014     if (IN_PERL_COMPILETIME) {
6015         HV * const table = GvHV(PL_hintgv);
6016         SV **ptr;
6017
6018         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6019             return &PL_core_reg_engine;
6020         ptr = hv_fetchs(table, "regcomp", FALSE);
6021         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6022             return &PL_core_reg_engine;
6023         return INT2PTR(regexp_engine*,SvIV(*ptr));
6024     }
6025     else {
6026         SV *ptr;
6027         if (!PL_curcop->cop_hints_hash)
6028             return &PL_core_reg_engine;
6029         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6030         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6031             return &PL_core_reg_engine;
6032         return INT2PTR(regexp_engine*,SvIV(ptr));
6033     }
6034 }
6035
6036
6037 REGEXP *
6038 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6039 {
6040     regexp_engine const *eng = current_re_engine();
6041     GET_RE_DEBUG_FLAGS_DECL;
6042
6043     PERL_ARGS_ASSERT_PREGCOMP;
6044
6045     /* Dispatch a request to compile a regexp to correct regexp engine. */
6046     DEBUG_COMPILE_r({
6047         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
6048                         PTR2UV(eng));
6049     });
6050     return CALLREGCOMP_ENG(eng, pattern, flags);
6051 }
6052 #endif
6053
6054 /* public(ish) entry point for the perl core's own regex compiling code.
6055  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6056  * pattern rather than a list of OPs, and uses the internal engine rather
6057  * than the current one */
6058
6059 REGEXP *
6060 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6061 {
6062     SV *pat = pattern; /* defeat constness! */
6063     PERL_ARGS_ASSERT_RE_COMPILE;
6064     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6065 #ifdef PERL_IN_XSUB_RE
6066                                 &my_reg_engine,
6067 #else
6068                                 &PL_core_reg_engine,
6069 #endif
6070                                 NULL, NULL, rx_flags, 0);
6071 }
6072
6073
6074 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6075  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6076  * point to the realloced string and length.
6077  *
6078  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6079  * stuff added */
6080
6081 static void
6082 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6083                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6084 {
6085     U8 *const src = (U8*)*pat_p;
6086     U8 *dst, *d;
6087     int n=0;
6088     STRLEN s = 0;
6089     bool do_end = 0;
6090     GET_RE_DEBUG_FLAGS_DECL;
6091
6092     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6093         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6094
6095     Newx(dst, *plen_p * 2 + 1, U8);
6096     d = dst;
6097
6098     while (s < *plen_p) {
6099         append_utf8_from_native_byte(src[s], &d);
6100         if (n < num_code_blocks) {
6101             if (!do_end && pRExC_state->code_blocks[n].start == s) {
6102                 pRExC_state->code_blocks[n].start = d - dst - 1;
6103                 assert(*(d - 1) == '(');
6104                 do_end = 1;
6105             }
6106             else if (do_end && pRExC_state->code_blocks[n].end == s) {
6107                 pRExC_state->code_blocks[n].end = d - dst - 1;
6108                 assert(*(d - 1) == ')');
6109                 do_end = 0;
6110                 n++;
6111             }
6112         }
6113         s++;
6114     }
6115     *d = '\0';
6116     *plen_p = d - dst;
6117     *pat_p = (char*) dst;
6118     SAVEFREEPV(*pat_p);
6119     RExC_orig_utf8 = RExC_utf8 = 1;
6120 }
6121
6122
6123
6124 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6125  * while recording any code block indices, and handling overloading,
6126  * nested qr// objects etc.  If pat is null, it will allocate a new
6127  * string, or just return the first arg, if there's only one.
6128  *
6129  * Returns the malloced/updated pat.
6130  * patternp and pat_count is the array of SVs to be concatted;
6131  * oplist is the optional list of ops that generated the SVs;
6132  * recompile_p is a pointer to a boolean that will be set if
6133  *   the regex will need to be recompiled.
6134  * delim, if non-null is an SV that will be inserted between each element
6135  */
6136
6137 static SV*
6138 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6139                 SV *pat, SV ** const patternp, int pat_count,
6140                 OP *oplist, bool *recompile_p, SV *delim)
6141 {
6142     SV **svp;
6143     int n = 0;
6144     bool use_delim = FALSE;
6145     bool alloced = FALSE;
6146
6147     /* if we know we have at least two args, create an empty string,
6148      * then concatenate args to that. For no args, return an empty string */
6149     if (!pat && pat_count != 1) {
6150         pat = newSVpvs("");
6151         SAVEFREESV(pat);
6152         alloced = TRUE;
6153     }
6154
6155     for (svp = patternp; svp < patternp + pat_count; svp++) {
6156         SV *sv;
6157         SV *rx  = NULL;
6158         STRLEN orig_patlen = 0;
6159         bool code = 0;
6160         SV *msv = use_delim ? delim : *svp;
6161         if (!msv) msv = &PL_sv_undef;
6162
6163         /* if we've got a delimiter, we go round the loop twice for each
6164          * svp slot (except the last), using the delimiter the second
6165          * time round */
6166         if (use_delim) {
6167             svp--;
6168             use_delim = FALSE;
6169         }
6170         else if (delim)
6171             use_delim = TRUE;
6172
6173         if (SvTYPE(msv) == SVt_PVAV) {
6174             /* we've encountered an interpolated array within
6175              * the pattern, e.g. /...@a..../. Expand the list of elements,
6176              * then recursively append elements.
6177              * The code in this block is based on S_pushav() */
6178
6179             AV *const av = (AV*)msv;
6180             const SSize_t maxarg = AvFILL(av) + 1;
6181             SV **array;
6182
6183             if (oplist) {
6184                 assert(oplist->op_type == OP_PADAV
6185                     || oplist->op_type == OP_RV2AV);
6186                 oplist = OpSIBLING(oplist);
6187             }
6188
6189             if (SvRMAGICAL(av)) {
6190                 SSize_t i;
6191
6192                 Newx(array, maxarg, SV*);
6193                 SAVEFREEPV(array);
6194                 for (i=0; i < maxarg; i++) {
6195                     SV ** const svp = av_fetch(av, i, FALSE);
6196                     array[i] = svp ? *svp : &PL_sv_undef;
6197                 }
6198             }
6199             else
6200                 array = AvARRAY(av);
6201
6202             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6203                                 array, maxarg, NULL, recompile_p,
6204                                 /* $" */
6205                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6206
6207             continue;
6208         }
6209
6210
6211         /* we make the assumption here that each op in the list of
6212          * op_siblings maps to one SV pushed onto the stack,
6213          * except for code blocks, with have both an OP_NULL and
6214          * and OP_CONST.
6215          * This allows us to match up the list of SVs against the
6216          * list of OPs to find the next code block.
6217          *
6218          * Note that       PUSHMARK PADSV PADSV ..
6219          * is optimised to
6220          *                 PADRANGE PADSV  PADSV  ..
6221          * so the alignment still works. */
6222
6223         if (oplist) {
6224             if (oplist->op_type == OP_NULL
6225                 && (oplist->op_flags & OPf_SPECIAL))
6226             {
6227                 assert(n < pRExC_state->num_code_blocks);
6228                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
6229                 pRExC_state->code_blocks[n].block = oplist;
6230                 pRExC_state->code_blocks[n].src_regex = NULL;
6231                 n++;
6232                 code = 1;
6233                 oplist = OpSIBLING(oplist); /* skip CONST */
6234                 assert(oplist);
6235             }
6236             oplist = OpSIBLING(oplist);;
6237         }
6238
6239         /* apply magic and QR overloading to arg */
6240
6241         SvGETMAGIC(msv);
6242         if (SvROK(msv) && SvAMAGIC(msv)) {
6243             SV *sv = AMG_CALLunary(msv, regexp_amg);
6244             if (sv) {
6245                 if (SvROK(sv))
6246                     sv = SvRV(sv);
6247                 if (SvTYPE(sv) != SVt_REGEXP)
6248                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6249                 msv = sv;
6250             }
6251         }
6252
6253         /* try concatenation overload ... */
6254         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6255                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6256         {
6257             sv_setsv(pat, sv);
6258             /* overloading involved: all bets are off over literal
6259              * code. Pretend we haven't seen it */
6260             pRExC_state->num_code_blocks -= n;
6261             n = 0;
6262         }
6263         else  {
6264             /* ... or failing that, try "" overload */
6265             while (SvAMAGIC(msv)
6266                     && (sv = AMG_CALLunary(msv, string_amg))
6267                     && sv != msv
6268                     &&  !(   SvROK(msv)
6269                           && SvROK(sv)
6270                           && SvRV(msv) == SvRV(sv))
6271             ) {
6272                 msv = sv;
6273                 SvGETMAGIC(msv);
6274             }
6275             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6276                 msv = SvRV(msv);
6277
6278             if (pat) {
6279                 /* this is a partially unrolled
6280                  *     sv_catsv_nomg(pat, msv);
6281                  * that allows us to adjust code block indices if
6282                  * needed */
6283                 STRLEN dlen;
6284                 char *dst = SvPV_force_nomg(pat, dlen);
6285                 orig_patlen = dlen;
6286                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6287                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6288                     sv_setpvn(pat, dst, dlen);
6289                     SvUTF8_on(pat);
6290                 }
6291                 sv_catsv_nomg(pat, msv);
6292                 rx = msv;
6293             }
6294             else
6295                 pat = msv;
6296
6297             if (code)
6298                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
6299         }
6300
6301         /* extract any code blocks within any embedded qr//'s */
6302         if (rx && SvTYPE(rx) == SVt_REGEXP
6303             && RX_ENGINE((REGEXP*)rx)->op_comp)
6304         {
6305
6306             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6307             if (ri->num_code_blocks) {
6308                 int i;
6309                 /* the presence of an embedded qr// with code means
6310                  * we should always recompile: the text of the
6311                  * qr// may not have changed, but it may be a
6312                  * different closure than last time */
6313                 *recompile_p = 1;
6314                 Renew(pRExC_state->code_blocks,
6315                     pRExC_state->num_code_blocks + ri->num_code_blocks,
6316                     struct reg_code_block);
6317                 pRExC_state->num_code_blocks += ri->num_code_blocks;
6318
6319                 for (i=0; i < ri->num_code_blocks; i++) {
6320                     struct reg_code_block *src, *dst;
6321                     STRLEN offset =  orig_patlen
6322                         + ReANY((REGEXP *)rx)->pre_prefix;
6323                     assert(n < pRExC_state->num_code_blocks);
6324                     src = &ri->code_blocks[i];
6325                     dst = &pRExC_state->code_blocks[n];
6326                     dst->start      = src->start + offset;
6327                     dst->end        = src->end   + offset;
6328                     dst->block      = src->block;
6329                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6330                                             src->src_regex
6331                                                 ? src->src_regex
6332                                                 : (REGEXP*)rx);
6333                     n++;
6334                 }
6335             }
6336         }
6337     }
6338     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6339     if (alloced)
6340         SvSETMAGIC(pat);
6341
6342     return pat;
6343 }
6344
6345
6346
6347 /* see if there are any run-time code blocks in the pattern.
6348  * False positives are allowed */
6349
6350 static bool
6351 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6352                     char *pat, STRLEN plen)
6353 {
6354     int n = 0;
6355     STRLEN s;
6356     
6357     PERL_UNUSED_CONTEXT;
6358
6359     for (s = 0; s < plen; s++) {
6360         if (n < pRExC_state->num_code_blocks
6361             && s == pRExC_state->code_blocks[n].start)
6362         {
6363             s = pRExC_state->code_blocks[n].end;
6364             n++;
6365             continue;
6366         }
6367         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6368          * positives here */
6369         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6370             (pat[s+2] == '{'
6371                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6372         )
6373             return 1;
6374     }
6375     return 0;
6376 }
6377
6378 /* Handle run-time code blocks. We will already have compiled any direct
6379  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6380  * copy of it, but with any literal code blocks blanked out and
6381  * appropriate chars escaped; then feed it into
6382  *
6383  *    eval "qr'modified_pattern'"
6384  *
6385  * For example,
6386  *
6387  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6388  *
6389  * becomes
6390  *
6391  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6392  *
6393  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6394  * and merge them with any code blocks of the original regexp.
6395  *
6396  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6397  * instead, just save the qr and return FALSE; this tells our caller that
6398  * the original pattern needs upgrading to utf8.
6399  */
6400
6401 static bool
6402 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6403     char *pat, STRLEN plen)
6404 {
6405     SV *qr;
6406
6407     GET_RE_DEBUG_FLAGS_DECL;
6408
6409     if (pRExC_state->runtime_code_qr) {
6410         /* this is the second time we've been called; this should
6411          * only happen if the main pattern got upgraded to utf8
6412          * during compilation; re-use the qr we compiled first time
6413          * round (which should be utf8 too)
6414          */
6415         qr = pRExC_state->runtime_code_qr;
6416         pRExC_state->runtime_code_qr = NULL;
6417         assert(RExC_utf8 && SvUTF8(qr));
6418     }
6419     else {
6420         int n = 0;
6421         STRLEN s;
6422         char *p, *newpat;
6423         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
6424         SV *sv, *qr_ref;
6425         dSP;
6426
6427         /* determine how many extra chars we need for ' and \ escaping */
6428         for (s = 0; s < plen; s++) {
6429             if (pat[s] == '\'' || pat[s] == '\\')
6430                 newlen++;
6431         }
6432
6433         Newx(newpat, newlen, char);
6434         p = newpat;
6435         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6436
6437         for (s = 0; s < plen; s++) {
6438             if (n < pRExC_state->num_code_blocks
6439                 && s == pRExC_state->code_blocks[n].start)
6440             {
6441                 /* blank out literal code block */
6442                 assert(pat[s] == '(');
6443                 while (s <= pRExC_state->code_blocks[n].end) {
6444                     *p++ = '_';
6445                     s++;
6446                 }
6447                 s--;
6448                 n++;
6449                 continue;
6450             }
6451             if (pat[s] == '\'' || pat[s] == '\\')
6452                 *p++ = '\\';
6453             *p++ = pat[s];
6454         }
6455         *p++ = '\'';
6456         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
6457             *p++ = 'x';
6458         *p++ = '\0';
6459         DEBUG_COMPILE_r({
6460             PerlIO_printf(Perl_debug_log,
6461                 "%sre-parsing pattern for runtime code:%s %s\n",
6462                 PL_colors[4],PL_colors[5],newpat);
6463         });
6464
6465         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6466         Safefree(newpat);
6467
6468         ENTER;
6469         SAVETMPS;
6470         save_re_context();
6471         PUSHSTACKi(PERLSI_REQUIRE);
6472         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6473          * parsing qr''; normally only q'' does this. It also alters
6474          * hints handling */
6475         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6476         SvREFCNT_dec_NN(sv);
6477         SPAGAIN;
6478         qr_ref = POPs;
6479         PUTBACK;
6480         {
6481             SV * const errsv = ERRSV;
6482             if (SvTRUE_NN(errsv))
6483             {
6484                 Safefree(pRExC_state->code_blocks);
6485                 /* use croak_sv ? */
6486                 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
6487             }
6488         }
6489         assert(SvROK(qr_ref));
6490         qr = SvRV(qr_ref);
6491         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6492         /* the leaving below frees the tmp qr_ref.
6493          * Give qr a life of its own */
6494         SvREFCNT_inc(qr);
6495         POPSTACK;
6496         FREETMPS;
6497         LEAVE;
6498
6499     }
6500
6501     if (!RExC_utf8 && SvUTF8(qr)) {
6502         /* first time through; the pattern got upgraded; save the
6503          * qr for the next time through */
6504         assert(!pRExC_state->runtime_code_qr);
6505         pRExC_state->runtime_code_qr = qr;
6506         return 0;
6507     }
6508
6509
6510     /* extract any code blocks within the returned qr//  */
6511
6512
6513     /* merge the main (r1) and run-time (r2) code blocks into one */
6514     {
6515         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6516         struct reg_code_block *new_block, *dst;
6517         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6518         int i1 = 0, i2 = 0;
6519
6520         if (!r2->num_code_blocks) /* we guessed wrong */
6521         {
6522             SvREFCNT_dec_NN(qr);
6523             return 1;
6524         }
6525
6526         Newx(new_block,
6527             r1->num_code_blocks + r2->num_code_blocks,
6528             struct reg_code_block);
6529         dst = new_block;
6530
6531         while (    i1 < r1->num_code_blocks
6532                 || i2 < r2->num_code_blocks)
6533         {
6534             struct reg_code_block *src;
6535             bool is_qr = 0;
6536
6537             if (i1 == r1->num_code_blocks) {
6538                 src = &r2->code_blocks[i2++];
6539                 is_qr = 1;
6540             }
6541             else if (i2 == r2->num_code_blocks)
6542                 src = &r1->code_blocks[i1++];
6543             else if (  r1->code_blocks[i1].start
6544                      < r2->code_blocks[i2].start)
6545             {
6546                 src = &r1->code_blocks[i1++];
6547                 assert(src->end < r2->code_blocks[i2].start);
6548             }
6549             else {
6550                 assert(  r1->code_blocks[i1].start
6551                        > r2->code_blocks[i2].start);
6552                 src = &r2->code_blocks[i2++];
6553                 is_qr = 1;
6554                 assert(src->end < r1->code_blocks[i1].start);
6555             }
6556
6557             assert(pat[src->start] == '(');
6558             assert(pat[src->end]   == ')');
6559             dst->start      = src->start;
6560             dst->end        = src->end;
6561             dst->block      = src->block;
6562             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6563                                     : src->src_regex;
6564             dst++;
6565         }
6566         r1->num_code_blocks += r2->num_code_blocks;
6567         Safefree(r1->code_blocks);
6568         r1->code_blocks = new_block;
6569     }
6570
6571     SvREFCNT_dec_NN(qr);
6572     return 1;
6573 }
6574
6575
6576 STATIC bool
6577 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6578                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6579                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6580                       STRLEN longest_length, bool eol, bool meol)
6581 {
6582     /* This is the common code for setting up the floating and fixed length
6583      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6584      * as to whether succeeded or not */
6585
6586     I32 t;
6587     SSize_t ml;
6588
6589     if (! (longest_length
6590            || (eol /* Can't have SEOL and MULTI */
6591                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6592           )
6593             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6594         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6595     {
6596         return FALSE;
6597     }
6598
6599     /* copy the information about the longest from the reg_scan_data
6600         over to the program. */
6601     if (SvUTF8(sv_longest)) {
6602         *rx_utf8 = sv_longest;
6603         *rx_substr = NULL;
6604     } else {
6605         *rx_substr = sv_longest;
6606         *rx_utf8 = NULL;
6607     }
6608     /* end_shift is how many chars that must be matched that
6609         follow this item. We calculate it ahead of time as once the
6610         lookbehind offset is added in we lose the ability to correctly
6611         calculate it.*/
6612     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6613     *rx_end_shift = ml - offset
6614         - longest_length + (SvTAIL(sv_longest) != 0)
6615         + lookbehind;
6616
6617     t = (eol/* Can't have SEOL and MULTI */
6618          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6619     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6620
6621     return TRUE;
6622 }
6623
6624 /*
6625  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6626  * regular expression into internal code.
6627  * The pattern may be passed either as:
6628  *    a list of SVs (patternp plus pat_count)
6629  *    a list of OPs (expr)
6630  * If both are passed, the SV list is used, but the OP list indicates
6631  * which SVs are actually pre-compiled code blocks
6632  *
6633  * The SVs in the list have magic and qr overloading applied to them (and
6634  * the list may be modified in-place with replacement SVs in the latter
6635  * case).
6636  *
6637  * If the pattern hasn't changed from old_re, then old_re will be
6638  * returned.
6639  *
6640  * eng is the current engine. If that engine has an op_comp method, then
6641  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6642  * do the initial concatenation of arguments and pass on to the external
6643  * engine.
6644  *
6645  * If is_bare_re is not null, set it to a boolean indicating whether the
6646  * arg list reduced (after overloading) to a single bare regex which has
6647  * been returned (i.e. /$qr/).
6648  *
6649  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6650  *
6651  * pm_flags contains the PMf_* flags, typically based on those from the
6652  * pm_flags field of the related PMOP. Currently we're only interested in
6653  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6654  *
6655  * We can't allocate space until we know how big the compiled form will be,
6656  * but we can't compile it (and thus know how big it is) until we've got a
6657  * place to put the code.  So we cheat:  we compile it twice, once with code
6658  * generation turned off and size counting turned on, and once "for real".
6659  * This also means that we don't allocate space until we are sure that the
6660  * thing really will compile successfully, and we never have to move the
6661  * code and thus invalidate pointers into it.  (Note that it has to be in
6662  * one piece because free() must be able to free it all.) [NB: not true in perl]
6663  *
6664  * Beware that the optimization-preparation code in here knows about some
6665  * of the structure of the compiled regexp.  [I'll say.]
6666  */
6667
6668 REGEXP *
6669 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6670                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6671                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6672 {
6673     REGEXP *rx;
6674     struct regexp *r;
6675     regexp_internal *ri;
6676     STRLEN plen;
6677     char *exp;
6678     regnode *scan;
6679     I32 flags;
6680     SSize_t minlen = 0;
6681     U32 rx_flags;
6682     SV *pat;
6683     SV *code_blocksv = NULL;
6684     SV** new_patternp = patternp;
6685
6686     /* these are all flags - maybe they should be turned
6687      * into a single int with different bit masks */
6688     I32 sawlookahead = 0;
6689     I32 sawplus = 0;
6690     I32 sawopen = 0;
6691     I32 sawminmod = 0;
6692
6693     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6694     bool recompile = 0;
6695     bool runtime_code = 0;
6696     scan_data_t data;
6697     RExC_state_t RExC_state;
6698     RExC_state_t * const pRExC_state = &RExC_state;
6699 #ifdef TRIE_STUDY_OPT
6700     int restudied = 0;
6701     RExC_state_t copyRExC_state;
6702 #endif
6703     GET_RE_DEBUG_FLAGS_DECL;
6704
6705     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6706
6707     DEBUG_r(if (!PL_colorset) reginitcolors());
6708
6709     /* Initialize these here instead of as-needed, as is quick and avoids
6710      * having to test them each time otherwise */
6711     if (! PL_AboveLatin1) {
6712 #ifdef DEBUGGING
6713         char * dump_len_string;
6714 #endif
6715
6716         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6717         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6718         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6719         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6720         PL_HasMultiCharFold =
6721                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6722
6723         /* This is calculated here, because the Perl program that generates the
6724          * static global ones doesn't currently have access to
6725          * NUM_ANYOF_CODE_POINTS */
6726         PL_InBitmap = _new_invlist(2);
6727         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6728                                                     NUM_ANYOF_CODE_POINTS - 1);
6729 #ifdef DEBUGGING
6730         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6731         if (   ! dump_len_string
6732             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6733         {
6734             PL_dump_re_max_len = 0;
6735         }
6736 #endif
6737     }
6738
6739     pRExC_state->code_blocks = NULL;
6740     pRExC_state->num_code_blocks = 0;
6741
6742     if (is_bare_re)
6743         *is_bare_re = FALSE;
6744
6745     if (expr && (expr->op_type == OP_LIST ||
6746                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6747         /* allocate code_blocks if needed */
6748         OP *o;
6749         int ncode = 0;
6750
6751         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6752             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6753                 ncode++; /* count of DO blocks */
6754         if (ncode) {
6755             pRExC_state->num_code_blocks = ncode;
6756             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
6757         }
6758     }
6759
6760     if (!pat_count) {
6761         /* compile-time pattern with just OP_CONSTs and DO blocks */
6762
6763         int n;
6764         OP *o;
6765
6766         /* find how many CONSTs there are */
6767         assert(expr);
6768         n = 0;
6769         if (expr->op_type == OP_CONST)
6770             n = 1;
6771         else
6772             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6773                 if (o->op_type == OP_CONST)
6774                     n++;
6775             }
6776
6777         /* fake up an SV array */
6778
6779         assert(!new_patternp);
6780         Newx(new_patternp, n, SV*);
6781         SAVEFREEPV(new_patternp);
6782         pat_count = n;
6783
6784         n = 0;
6785         if (expr->op_type == OP_CONST)
6786             new_patternp[n] = cSVOPx_sv(expr);
6787         else
6788             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6789                 if (o->op_type == OP_CONST)
6790                     new_patternp[n++] = cSVOPo_sv;
6791             }
6792
6793     }
6794
6795     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6796         "Assembling pattern from %d elements%s\n", pat_count,
6797             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6798
6799     /* set expr to the first arg op */
6800
6801     if (pRExC_state->num_code_blocks
6802          && expr->op_type != OP_CONST)
6803     {
6804             expr = cLISTOPx(expr)->op_first;
6805             assert(   expr->op_type == OP_PUSHMARK
6806                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6807                    || expr->op_type == OP_PADRANGE);
6808             expr = OpSIBLING(expr);
6809     }
6810
6811     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6812                         expr, &recompile, NULL);
6813
6814     /* handle bare (possibly after overloading) regex: foo =~ $re */
6815     {
6816         SV *re = pat;
6817         if (SvROK(re))
6818             re = SvRV(re);
6819         if (SvTYPE(re) == SVt_REGEXP) {
6820             if (is_bare_re)
6821                 *is_bare_re = TRUE;
6822             SvREFCNT_inc(re);
6823             Safefree(pRExC_state->code_blocks);
6824             DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6825                 "Precompiled pattern%s\n",
6826                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6827
6828             return (REGEXP*)re;
6829         }
6830     }
6831
6832     exp = SvPV_nomg(pat, plen);
6833
6834     if (!eng->op_comp) {
6835         if ((SvUTF8(pat) && IN_BYTES)
6836                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6837         {
6838             /* make a temporary copy; either to convert to bytes,
6839              * or to avoid repeating get-magic / overloaded stringify */
6840             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6841                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6842         }
6843         Safefree(pRExC_state->code_blocks);
6844         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6845     }
6846
6847     /* ignore the utf8ness if the pattern is 0 length */
6848     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6849
6850     RExC_uni_semantics = 0;
6851     RExC_seen_unfolded_sharp_s = 0;
6852     RExC_contains_locale = 0;
6853     RExC_contains_i = 0;
6854     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
6855     pRExC_state->runtime_code_qr = NULL;
6856     RExC_frame_head= NULL;
6857     RExC_frame_last= NULL;
6858     RExC_frame_count= 0;
6859
6860     DEBUG_r({
6861         RExC_mysv1= sv_newmortal();
6862         RExC_mysv2= sv_newmortal();
6863     });
6864     DEBUG_COMPILE_r({
6865             SV *dsv= sv_newmortal();
6866             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6867             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
6868                           PL_colors[4],PL_colors[5],s);
6869         });
6870
6871   redo_first_pass:
6872     /* we jump here if we have to recompile, e.g., from upgrading the pattern
6873      * to utf8 */
6874
6875     if ((pm_flags & PMf_USE_RE_EVAL)
6876                 /* this second condition covers the non-regex literal case,
6877                  * i.e.  $foo =~ '(?{})'. */
6878                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6879     )
6880         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6881
6882     /* return old regex if pattern hasn't changed */
6883     /* XXX: note in the below we have to check the flags as well as the
6884      * pattern.
6885      *
6886      * Things get a touch tricky as we have to compare the utf8 flag
6887      * independently from the compile flags.  */
6888
6889     if (   old_re
6890         && !recompile
6891         && !!RX_UTF8(old_re) == !!RExC_utf8
6892         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
6893         && RX_PRECOMP(old_re)
6894         && RX_PRELEN(old_re) == plen
6895         && memEQ(RX_PRECOMP(old_re), exp, plen)
6896         && !runtime_code /* with runtime code, always recompile */ )
6897     {
6898         Safefree(pRExC_state->code_blocks);
6899         return old_re;
6900     }
6901
6902     rx_flags = orig_rx_flags;
6903
6904     if (rx_flags & PMf_FOLD) {
6905         RExC_contains_i = 1;
6906     }
6907     if (   initial_charset == REGEX_DEPENDS_CHARSET
6908         && (RExC_utf8 ||RExC_uni_semantics))
6909     {
6910
6911         /* Set to use unicode semantics if the pattern is in utf8 and has the
6912          * 'depends' charset specified, as it means unicode when utf8  */
6913         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6914     }
6915
6916     RExC_precomp = exp;
6917     RExC_precomp_adj = 0;
6918     RExC_flags = rx_flags;
6919     RExC_pm_flags = pm_flags;
6920
6921     if (runtime_code) {
6922         assert(TAINTING_get || !TAINT_get);
6923         if (TAINT_get)
6924             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
6925
6926         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
6927             /* whoops, we have a non-utf8 pattern, whilst run-time code
6928              * got compiled as utf8. Try again with a utf8 pattern */
6929             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6930                                     pRExC_state->num_code_blocks);
6931             goto redo_first_pass;
6932         }
6933     }
6934     assert(!pRExC_state->runtime_code_qr);
6935
6936     RExC_sawback = 0;
6937
6938     RExC_seen = 0;
6939     RExC_maxlen = 0;
6940     RExC_in_lookbehind = 0;
6941     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
6942     RExC_extralen = 0;
6943     RExC_override_recoding = 0;
6944 #ifdef EBCDIC
6945     RExC_recode_x_to_native = 0;
6946 #endif
6947     RExC_in_multi_char_class = 0;
6948
6949     /* First pass: determine size, legality. */
6950     RExC_parse = exp;
6951     RExC_start = RExC_adjusted_start = exp;
6952     RExC_end = exp + plen;
6953     RExC_precomp_end = RExC_end;
6954     RExC_naughty = 0;
6955     RExC_npar = 1;
6956     RExC_nestroot = 0;
6957     RExC_size = 0L;
6958     RExC_emit = (regnode *) &RExC_emit_dummy;
6959     RExC_whilem_seen = 0;
6960     RExC_open_parens = NULL;
6961     RExC_close_parens = NULL;
6962     RExC_opend = NULL;
6963     RExC_paren_names = NULL;
6964 #ifdef DEBUGGING
6965     RExC_paren_name_list = NULL;
6966 #endif
6967     RExC_recurse = NULL;
6968     RExC_study_chunk_recursed = NULL;
6969     RExC_study_chunk_recursed_bytes= 0;
6970     RExC_recurse_count = 0;
6971     pRExC_state->code_index = 0;
6972
6973     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
6974      * code makes sure the final byte is an uncounted NUL.  But should this
6975      * ever not be the case, lots of things could read beyond the end of the
6976      * buffer: loops like
6977      *      while(isFOO(*RExC_parse)) RExC_parse++;
6978      *      strchr(RExC_parse, "foo");
6979      * etc.  So it is worth noting. */
6980     assert(*RExC_end == '\0');
6981
6982     DEBUG_PARSE_r(
6983         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
6984         RExC_lastnum=0;
6985         RExC_lastparse=NULL;
6986     );
6987     /* reg may croak on us, not giving us a chance to free
6988        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
6989        need it to survive as long as the regexp (qr/(?{})/).
6990        We must check that code_blocksv is not already set, because we may
6991        have jumped back to restart the sizing pass. */
6992     if (pRExC_state->code_blocks && !code_blocksv) {
6993         code_blocksv = newSV_type(SVt_PV);
6994         SAVEFREESV(code_blocksv);
6995         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
6996         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
6997     }
6998     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6999         /* It's possible to write a regexp in ascii that represents Unicode
7000         codepoints outside of the byte range, such as via \x{100}. If we
7001         detect such a sequence we have to convert the entire pattern to utf8
7002         and then recompile, as our sizing calculation will have been based
7003         on 1 byte == 1 character, but we will need to use utf8 to encode
7004         at least some part of the pattern, and therefore must convert the whole
7005         thing.
7006         -- dmq */
7007         if (flags & RESTART_PASS1) {
7008             if (flags & NEED_UTF8) {
7009                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7010                                     pRExC_state->num_code_blocks);
7011             }
7012             else {
7013                 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
7014                 "Need to redo pass 1\n"));
7015             }
7016
7017             goto redo_first_pass;
7018         }
7019         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#"UVxf"", (UV) flags);
7020     }
7021     if (code_blocksv)
7022         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
7023
7024     DEBUG_PARSE_r({
7025         PerlIO_printf(Perl_debug_log,
7026             "Required size %"IVdf" nodes\n"
7027             "Starting second pass (creation)\n",
7028             (IV)RExC_size);
7029         RExC_lastnum=0;
7030         RExC_lastparse=NULL;
7031     });
7032
7033     /* The first pass could have found things that force Unicode semantics */
7034     if ((RExC_utf8 || RExC_uni_semantics)
7035          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7036     {
7037         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7038     }
7039
7040     /* Small enough for pointer-storage convention?
7041        If extralen==0, this means that we will not need long jumps. */
7042     if (RExC_size >= 0x10000L && RExC_extralen)
7043         RExC_size += RExC_extralen;
7044     else
7045         RExC_extralen = 0;
7046     if (RExC_whilem_seen > 15)
7047         RExC_whilem_seen = 15;
7048
7049     /* Allocate space and zero-initialize. Note, the two step process
7050        of zeroing when in debug mode, thus anything assigned has to
7051        happen after that */
7052     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7053     r = ReANY(rx);
7054     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7055          char, regexp_internal);
7056     if ( r == NULL || ri == NULL )
7057         FAIL("Regexp out of space");
7058 #ifdef DEBUGGING
7059     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7060     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7061          char);
7062 #else
7063     /* bulk initialize base fields with 0. */
7064     Zero(ri, sizeof(regexp_internal), char);
7065 #endif
7066
7067     /* non-zero initialization begins here */
7068     RXi_SET( r, ri );
7069     r->engine= eng;
7070     r->extflags = rx_flags;
7071     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7072
7073     if (pm_flags & PMf_IS_QR) {
7074         ri->code_blocks = pRExC_state->code_blocks;
7075         ri->num_code_blocks = pRExC_state->num_code_blocks;
7076     }
7077     else
7078     {
7079         int n;
7080         for (n = 0; n < pRExC_state->num_code_blocks; n++)
7081             if (pRExC_state->code_blocks[n].src_regex)
7082                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
7083         if(pRExC_state->code_blocks)
7084             SAVEFREEPV(pRExC_state->code_blocks); /* often null */
7085     }
7086
7087     {
7088         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7089         bool has_charset = (get_regex_charset(r->extflags)
7090                                                     != REGEX_DEPENDS_CHARSET);
7091
7092         /* The caret is output if there are any defaults: if not all the STD
7093          * flags are set, or if no character set specifier is needed */
7094         bool has_default =
7095                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7096                     || ! has_charset);
7097         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7098                                                    == REG_RUN_ON_COMMENT_SEEN);
7099         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7100                             >> RXf_PMf_STD_PMMOD_SHIFT);
7101         const char *fptr = STD_PAT_MODS;        /*"msixn"*/
7102         char *p;
7103
7104         /* We output all the necessary flags; we never output a minus, as all
7105          * those are defaults, so are
7106          * covered by the caret */
7107         const STRLEN wraplen = plen + has_p + has_runon
7108             + has_default       /* If needs a caret */
7109             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7110
7111                 /* If needs a character set specifier */
7112             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7113             + (sizeof("(?:)") - 1);
7114
7115         /* make sure PL_bitcount bounds not exceeded */
7116         assert(sizeof(STD_PAT_MODS) <= 8);
7117
7118         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
7119         r->xpv_len_u.xpvlenu_pv = p;
7120         if (RExC_utf8)
7121             SvFLAGS(rx) |= SVf_UTF8;
7122         *p++='('; *p++='?';
7123
7124         /* If a default, cover it using the caret */
7125         if (has_default) {
7126             *p++= DEFAULT_PAT_MOD;
7127         }
7128         if (has_charset) {
7129             STRLEN len;
7130             const char* const name = get_regex_charset_name(r->extflags, &len);
7131             Copy(name, p, len, char);
7132             p += len;
7133         }
7134         if (has_p)
7135             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7136         {
7137             char ch;
7138             while((ch = *fptr++)) {
7139                 if(reganch & 1)
7140                     *p++ = ch;
7141                 reganch >>= 1;
7142             }
7143         }
7144
7145         *p++ = ':';
7146         Copy(RExC_precomp, p, plen, char);
7147         assert ((RX_WRAPPED(rx) - p) < 16);
7148         r->pre_prefix = p - RX_WRAPPED(rx);
7149         p += plen;
7150         if (has_runon)
7151             *p++ = '\n';
7152         *p++ = ')';
7153         *p = 0;
7154         SvCUR_set(rx, p - RX_WRAPPED(rx));
7155     }
7156
7157     r->intflags = 0;
7158     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7159
7160     /* setup various meta data about recursion, this all requires
7161      * RExC_npar to be correctly set, and a bit later on we clear it */
7162     if (RExC_seen & REG_RECURSE_SEEN) {
7163         Newxz(RExC_open_parens, RExC_npar,regnode *);
7164         SAVEFREEPV(RExC_open_parens);
7165         Newxz(RExC_close_parens,RExC_npar,regnode *);
7166         SAVEFREEPV(RExC_close_parens);
7167     }
7168     if (RExC_seen & (REG_RECURSE_SEEN | REG_GOSTART_SEEN)) {
7169         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7170          * So its 1 if there are no parens. */
7171         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7172                                          ((RExC_npar & 0x07) != 0);
7173         Newx(RExC_study_chunk_recursed,
7174              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7175         SAVEFREEPV(RExC_study_chunk_recursed);
7176     }
7177
7178     /* Useful during FAIL. */
7179 #ifdef RE_TRACK_PATTERN_OFFSETS
7180     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7181     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
7182                           "%s %"UVuf" bytes for offset annotations.\n",
7183                           ri->u.offsets ? "Got" : "Couldn't get",
7184                           (UV)((2*RExC_size+1) * sizeof(U32))));
7185 #endif
7186     SetProgLen(ri,RExC_size);
7187     RExC_rx_sv = rx;
7188     RExC_rx = r;
7189     RExC_rxi = ri;
7190
7191     /* Second pass: emit code. */
7192     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7193     RExC_pm_flags = pm_flags;
7194     RExC_parse = exp;
7195     RExC_end = exp + plen;
7196     RExC_naughty = 0;
7197     RExC_npar = 1;
7198     RExC_emit_start = ri->program;
7199     RExC_emit = ri->program;
7200     RExC_emit_bound = ri->program + RExC_size + 1;
7201     pRExC_state->code_index = 0;
7202
7203     *((char*) RExC_emit++) = (char) REG_MAGIC;
7204     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7205         ReREFCNT_dec(rx);
7206         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags);
7207     }
7208     /* XXXX To minimize changes to RE engine we always allocate
7209        3-units-long substrs field. */
7210     Newx(r->substrs, 1, struct reg_substr_data);
7211     if (RExC_recurse_count) {
7212         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
7213         SAVEFREEPV(RExC_recurse);
7214     }
7215
7216   reStudy:
7217     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7218     DEBUG_r(
7219         RExC_study_chunk_recursed_count= 0;
7220     );
7221     Zero(r->substrs, 1, struct reg_substr_data);
7222     if (RExC_study_chunk_recursed) {
7223         Zero(RExC_study_chunk_recursed,
7224              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7225     }
7226
7227
7228 #ifdef TRIE_STUDY_OPT
7229     if (!restudied) {
7230         StructCopy(&zero_scan_data, &data, scan_data_t);
7231         copyRExC_state = RExC_state;
7232     } else {
7233         U32 seen=RExC_seen;
7234         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
7235
7236         RExC_state = copyRExC_state;
7237         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7238             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7239         else
7240             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7241         StructCopy(&zero_scan_data, &data, scan_data_t);
7242     }
7243 #else
7244     StructCopy(&zero_scan_data, &data, scan_data_t);
7245 #endif
7246
7247     /* Dig out information for optimizations. */
7248     r->extflags = RExC_flags; /* was pm_op */
7249     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7250
7251     if (UTF)
7252         SvUTF8_on(rx);  /* Unicode in it? */
7253     ri->regstclass = NULL;
7254     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7255         r->intflags |= PREGf_NAUGHTY;
7256     scan = ri->program + 1;             /* First BRANCH. */
7257
7258     /* testing for BRANCH here tells us whether there is "must appear"
7259        data in the pattern. If there is then we can use it for optimisations */
7260     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7261                                                   */
7262         SSize_t fake;
7263         STRLEN longest_float_length, longest_fixed_length;
7264         regnode_ssc ch_class; /* pointed to by data */
7265         int stclass_flag;
7266         SSize_t last_close = 0; /* pointed to by data */
7267         regnode *first= scan;
7268         regnode *first_next= regnext(first);
7269         /*
7270          * Skip introductions and multiplicators >= 1
7271          * so that we can extract the 'meat' of the pattern that must
7272          * match in the large if() sequence following.
7273          * NOTE that EXACT is NOT covered here, as it is normally
7274          * picked up by the optimiser separately.
7275          *
7276          * This is unfortunate as the optimiser isnt handling lookahead
7277          * properly currently.
7278          *
7279          */
7280         while ((OP(first) == OPEN && (sawopen = 1)) ||
7281                /* An OR of *one* alternative - should not happen now. */
7282             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7283             /* for now we can't handle lookbehind IFMATCH*/
7284             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7285             (OP(first) == PLUS) ||
7286             (OP(first) == MINMOD) ||
7287                /* An {n,m} with n>0 */
7288             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7289             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7290         {
7291                 /*
7292                  * the only op that could be a regnode is PLUS, all the rest
7293                  * will be regnode_1 or regnode_2.
7294                  *
7295                  * (yves doesn't think this is true)
7296                  */
7297                 if (OP(first) == PLUS)
7298                     sawplus = 1;
7299                 else {
7300                     if (OP(first) == MINMOD)
7301                         sawminmod = 1;
7302                     first += regarglen[OP(first)];
7303                 }
7304                 first = NEXTOPER(first);
7305                 first_next= regnext(first);
7306         }
7307
7308         /* Starting-point info. */
7309       again:
7310         DEBUG_PEEP("first:",first,0);
7311         /* Ignore EXACT as we deal with it later. */
7312         if (PL_regkind[OP(first)] == EXACT) {
7313             if (OP(first) == EXACT || OP(first) == EXACTL)
7314                 NOOP;   /* Empty, get anchored substr later. */
7315             else
7316                 ri->regstclass = first;
7317         }
7318 #ifdef TRIE_STCLASS
7319         else if (PL_regkind[OP(first)] == TRIE &&
7320                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7321         {
7322             /* this can happen only on restudy */
7323             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7324         }
7325 #endif
7326         else if (REGNODE_SIMPLE(OP(first)))
7327             ri->regstclass = first;
7328         else if (PL_regkind[OP(first)] == BOUND ||
7329                  PL_regkind[OP(first)] == NBOUND)
7330             ri->regstclass = first;
7331         else if (PL_regkind[OP(first)] == BOL) {
7332             r->intflags |= (OP(first) == MBOL
7333                            ? PREGf_ANCH_MBOL
7334                            : PREGf_ANCH_SBOL);
7335             first = NEXTOPER(first);
7336             goto again;
7337         }
7338         else if (OP(first) == GPOS) {
7339             r->intflags |= PREGf_ANCH_GPOS;
7340             first = NEXTOPER(first);
7341             goto again;
7342         }
7343         else if ((!sawopen || !RExC_sawback) &&
7344             !sawlookahead &&
7345             (OP(first) == STAR &&
7346             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7347             !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
7348         {
7349             /* turn .* into ^.* with an implied $*=1 */
7350             const int type =
7351                 (OP(NEXTOPER(first)) == REG_ANY)
7352                     ? PREGf_ANCH_MBOL
7353                     : PREGf_ANCH_SBOL;
7354             r->intflags |= (type | PREGf_IMPLICIT);
7355             first = NEXTOPER(first);
7356             goto again;
7357         }
7358         if (sawplus && !sawminmod && !sawlookahead
7359             && (!sawopen || !RExC_sawback)
7360             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
7361             /* x+ must match at the 1st pos of run of x's */
7362             r->intflags |= PREGf_SKIP;
7363
7364         /* Scan is after the zeroth branch, first is atomic matcher. */
7365 #ifdef TRIE_STUDY_OPT
7366         DEBUG_PARSE_r(
7367             if (!restudied)
7368                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
7369                               (IV)(first - scan + 1))
7370         );
7371 #else
7372         DEBUG_PARSE_r(
7373             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
7374                 (IV)(first - scan + 1))
7375         );
7376 #endif
7377
7378
7379         /*
7380         * If there's something expensive in the r.e., find the
7381         * longest literal string that must appear and make it the
7382         * regmust.  Resolve ties in favor of later strings, since
7383         * the regstart check works with the beginning of the r.e.
7384         * and avoiding duplication strengthens checking.  Not a
7385         * strong reason, but sufficient in the absence of others.
7386         * [Now we resolve ties in favor of the earlier string if
7387         * it happens that c_offset_min has been invalidated, since the
7388         * earlier string may buy us something the later one won't.]
7389         */
7390
7391         data.longest_fixed = newSVpvs("");
7392         data.longest_float = newSVpvs("");
7393         data.last_found = newSVpvs("");
7394         data.longest = &(data.longest_fixed);
7395         ENTER_with_name("study_chunk");
7396         SAVEFREESV(data.longest_fixed);
7397         SAVEFREESV(data.longest_float);
7398         SAVEFREESV(data.last_found);
7399         first = scan;
7400         if (!ri->regstclass) {
7401             ssc_init(pRExC_state, &ch_class);
7402             data.start_class = &ch_class;
7403             stclass_flag = SCF_DO_STCLASS_AND;
7404         } else                          /* XXXX Check for BOUND? */
7405             stclass_flag = 0;
7406         data.last_closep = &last_close;
7407
7408         DEBUG_RExC_seen();
7409         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7410                              scan + RExC_size, /* Up to end */
7411             &data, -1, 0, NULL,
7412             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7413                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7414             0);
7415
7416
7417         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7418
7419
7420         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
7421              && data.last_start_min == 0 && data.last_end > 0
7422              && !RExC_seen_zerolen
7423              && !(RExC_seen & REG_VERBARG_SEEN)
7424              && !(RExC_seen & REG_GPOS_SEEN)
7425         ){
7426             r->extflags |= RXf_CHECK_ALL;
7427         }
7428         scan_commit(pRExC_state, &data,&minlen,0);
7429
7430         longest_float_length = CHR_SVLEN(data.longest_float);
7431
7432         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
7433                    && data.offset_fixed == data.offset_float_min
7434                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
7435             && S_setup_longest (aTHX_ pRExC_state,
7436                                     data.longest_float,
7437                                     &(r->float_utf8),
7438                                     &(r->float_substr),
7439                                     &(r->float_end_shift),
7440                                     data.lookbehind_float,
7441                                     data.offset_float_min,
7442                                     data.minlen_float,
7443                                     longest_float_length,
7444                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
7445                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
7446         {
7447             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
7448             r->float_max_offset = data.offset_float_max;
7449             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
7450                 r->float_max_offset -= data.lookbehind_float;
7451             SvREFCNT_inc_simple_void_NN(data.longest_float);
7452         }
7453         else {
7454             r->float_substr = r->float_utf8 = NULL;
7455             longest_float_length = 0;
7456         }
7457
7458         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
7459
7460         if (S_setup_longest (aTHX_ pRExC_state,
7461                                 data.longest_fixed,
7462                                 &(r->anchored_utf8),
7463                                 &(r->anchored_substr),
7464                                 &(r->anchored_end_shift),
7465                                 data.lookbehind_fixed,
7466                                 data.offset_fixed,
7467                                 data.minlen_fixed,
7468                                 longest_fixed_length,
7469                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7470                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7471         {
7472             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7473             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7474         }
7475         else {
7476             r->anchored_substr = r->anchored_utf8 = NULL;
7477             longest_fixed_length = 0;
7478         }
7479         LEAVE_with_name("study_chunk");
7480
7481         if (ri->regstclass
7482             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7483             ri->regstclass = NULL;
7484
7485         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7486             && stclass_flag
7487             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7488             && is_ssc_worth_it(pRExC_state, data.start_class))
7489         {
7490             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7491
7492             ssc_finalize(pRExC_state, data.start_class);
7493
7494             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7495             StructCopy(data.start_class,
7496                        (regnode_ssc*)RExC_rxi->data->data[n],
7497                        regnode_ssc);
7498             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7499             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7500             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7501                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7502                       PerlIO_printf(Perl_debug_log,
7503                                     "synthetic stclass \"%s\".\n",
7504                                     SvPVX_const(sv));});
7505             data.start_class = NULL;
7506         }
7507
7508         /* A temporary algorithm prefers floated substr to fixed one to dig
7509          * more info. */
7510         if (longest_fixed_length > longest_float_length) {
7511             r->substrs->check_ix = 0;
7512             r->check_end_shift = r->anchored_end_shift;
7513             r->check_substr = r->anchored_substr;
7514             r->check_utf8 = r->anchored_utf8;
7515             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7516             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7517                 r->intflags |= PREGf_NOSCAN;
7518         }
7519         else {
7520             r->substrs->check_ix = 1;
7521             r->check_end_shift = r->float_end_shift;
7522             r->check_substr = r->float_substr;
7523             r->check_utf8 = r->float_utf8;
7524             r->check_offset_min = r->float_min_offset;
7525             r->check_offset_max = r->float_max_offset;
7526         }
7527         if ((r->check_substr || r->check_utf8) ) {
7528             r->extflags |= RXf_USE_INTUIT;
7529             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7530                 r->extflags |= RXf_INTUIT_TAIL;
7531         }
7532         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7533
7534         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7535         if ( (STRLEN)minlen < longest_float_length )
7536             minlen= longest_float_length;
7537         if ( (STRLEN)minlen < longest_fixed_length )
7538             minlen= longest_fixed_length;
7539         */
7540     }
7541     else {
7542         /* Several toplevels. Best we can is to set minlen. */
7543         SSize_t fake;
7544         regnode_ssc ch_class;
7545         SSize_t last_close = 0;
7546
7547         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
7548
7549         scan = ri->program + 1;
7550         ssc_init(pRExC_state, &ch_class);
7551         data.start_class = &ch_class;
7552         data.last_closep = &last_close;
7553
7554         DEBUG_RExC_seen();
7555         minlen = study_chunk(pRExC_state,
7556             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7557             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7558                                                       ? SCF_TRIE_DOING_RESTUDY
7559                                                       : 0),
7560             0);
7561
7562         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7563
7564         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7565                 = r->float_substr = r->float_utf8 = NULL;
7566
7567         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7568             && is_ssc_worth_it(pRExC_state, data.start_class))
7569         {
7570             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7571
7572             ssc_finalize(pRExC_state, data.start_class);
7573
7574             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7575             StructCopy(data.start_class,
7576                        (regnode_ssc*)RExC_rxi->data->data[n],
7577                        regnode_ssc);
7578             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7579             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7580             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7581                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7582                       PerlIO_printf(Perl_debug_log,
7583                                     "synthetic stclass \"%s\".\n",
7584                                     SvPVX_const(sv));});
7585             data.start_class = NULL;
7586         }
7587     }
7588
7589     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7590         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7591         r->maxlen = REG_INFTY;
7592     }
7593     else {
7594         r->maxlen = RExC_maxlen;
7595     }
7596
7597     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7598        the "real" pattern. */
7599     DEBUG_OPTIMISE_r({
7600         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%"IVdf"\n",
7601                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7602     });
7603     r->minlenret = minlen;
7604     if (r->minlen < minlen)
7605         r->minlen = minlen;
7606
7607     if (RExC_seen & REG_GPOS_SEEN)
7608         r->intflags |= PREGf_GPOS_SEEN;
7609     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7610         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7611                                                 lookbehind */
7612     if (pRExC_state->num_code_blocks)
7613         r->extflags |= RXf_EVAL_SEEN;
7614     if (RExC_seen & REG_VERBARG_SEEN)
7615     {
7616         r->intflags |= PREGf_VERBARG_SEEN;
7617         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7618     }
7619     if (RExC_seen & REG_CUTGROUP_SEEN)
7620         r->intflags |= PREGf_CUTGROUP_SEEN;
7621     if (pm_flags & PMf_USE_RE_EVAL)
7622         r->intflags |= PREGf_USE_RE_EVAL;
7623     if (RExC_paren_names)
7624         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7625     else
7626         RXp_PAREN_NAMES(r) = NULL;
7627
7628     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7629      * so it can be used in pp.c */
7630     if (r->intflags & PREGf_ANCH)
7631         r->extflags |= RXf_IS_ANCHORED;
7632
7633
7634     {
7635         /* this is used to identify "special" patterns that might result
7636          * in Perl NOT calling the regex engine and instead doing the match "itself",
7637          * particularly special cases in split//. By having the regex compiler
7638          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7639          * we avoid weird issues with equivalent patterns resulting in different behavior,
7640          * AND we allow non Perl engines to get the same optimizations by the setting the
7641          * flags appropriately - Yves */
7642         regnode *first = ri->program + 1;
7643         U8 fop = OP(first);
7644         regnode *next = regnext(first);
7645         U8 nop = OP(next);
7646
7647         if (PL_regkind[fop] == NOTHING && nop == END)
7648             r->extflags |= RXf_NULL;
7649         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7650             /* when fop is SBOL first->flags will be true only when it was
7651              * produced by parsing /\A/, and not when parsing /^/. This is
7652              * very important for the split code as there we want to
7653              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7654              * See rt #122761 for more details. -- Yves */
7655             r->extflags |= RXf_START_ONLY;
7656         else if (fop == PLUS
7657                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7658                  && nop == END)
7659             r->extflags |= RXf_WHITE;
7660         else if ( r->extflags & RXf_SPLIT
7661                   && (fop == EXACT || fop == EXACTL)
7662                   && STR_LEN(first) == 1
7663                   && *(STRING(first)) == ' '
7664                   && nop == END )
7665             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7666
7667     }
7668
7669     if (RExC_contains_locale) {
7670         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7671     }
7672
7673 #ifdef DEBUGGING
7674     if (RExC_paren_names) {
7675         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7676         ri->data->data[ri->name_list_idx]
7677                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7678     } else
7679 #endif
7680         ri->name_list_idx = 0;
7681
7682     if (RExC_recurse_count) {
7683         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
7684             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
7685             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
7686         }
7687     }
7688     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7689     /* assume we don't need to swap parens around before we match */
7690     DEBUG_TEST_r({
7691         PerlIO_printf(Perl_debug_log,"study_chunk_recursed_count: %lu\n",
7692             (unsigned long)RExC_study_chunk_recursed_count);
7693     });
7694     DEBUG_DUMP_r({
7695         DEBUG_RExC_seen();
7696         PerlIO_printf(Perl_debug_log,"Final program:\n");
7697         regdump(r);
7698     });
7699 #ifdef RE_TRACK_PATTERN_OFFSETS
7700     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7701         const STRLEN len = ri->u.offsets[0];
7702         STRLEN i;
7703         GET_RE_DEBUG_FLAGS_DECL;
7704         PerlIO_printf(Perl_debug_log,
7705                       "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
7706         for (i = 1; i <= len; i++) {
7707             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7708                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
7709                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7710             }
7711         PerlIO_printf(Perl_debug_log, "\n");
7712     });
7713 #endif
7714
7715 #ifdef USE_ITHREADS
7716     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7717      * by setting the regexp SV to readonly-only instead. If the
7718      * pattern's been recompiled, the USEDness should remain. */
7719     if (old_re && SvREADONLY(old_re))
7720         SvREADONLY_on(rx);
7721 #endif
7722     return rx;
7723 }
7724
7725
7726 SV*
7727 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7728                     const U32 flags)
7729 {
7730     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7731
7732     PERL_UNUSED_ARG(value);
7733
7734     if (flags & RXapif_FETCH) {
7735         return reg_named_buff_fetch(rx, key, flags);
7736     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7737         Perl_croak_no_modify();
7738         return NULL;
7739     } else if (flags & RXapif_EXISTS) {
7740         return reg_named_buff_exists(rx, key, flags)
7741             ? &PL_sv_yes
7742             : &PL_sv_no;
7743     } else if (flags & RXapif_REGNAMES) {
7744         return reg_named_buff_all(rx, flags);
7745     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7746         return reg_named_buff_scalar(rx, flags);
7747     } else {
7748         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7749         return NULL;
7750     }
7751 }
7752
7753 SV*
7754 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7755                          const U32 flags)
7756 {
7757     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7758     PERL_UNUSED_ARG(lastkey);
7759
7760     if (flags & RXapif_FIRSTKEY)
7761         return reg_named_buff_firstkey(rx, flags);
7762     else if (flags & RXapif_NEXTKEY)
7763         return reg_named_buff_nextkey(rx, flags);
7764     else {
7765         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7766                                             (int)flags);
7767         return NULL;
7768     }
7769 }
7770
7771 SV*
7772 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7773                           const U32 flags)
7774 {
7775     AV *retarray = NULL;
7776     SV *ret;
7777     struct regexp *const rx = ReANY(r);
7778
7779     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7780
7781     if (flags & RXapif_ALL)
7782         retarray=newAV();
7783
7784     if (rx && RXp_PAREN_NAMES(rx)) {
7785         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7786         if (he_str) {
7787             IV i;
7788             SV* sv_dat=HeVAL(he_str);
7789             I32 *nums=(I32*)SvPVX(sv_dat);
7790             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7791                 if ((I32)(rx->nparens) >= nums[i]
7792                     && rx->offs[nums[i]].start != -1
7793                     && rx->offs[nums[i]].end != -1)
7794                 {
7795                     ret = newSVpvs("");
7796                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7797                     if (!retarray)
7798                         return ret;
7799                 } else {
7800                     if (retarray)
7801                         ret = newSVsv(&PL_sv_undef);
7802                 }
7803                 if (retarray)
7804                     av_push(retarray, ret);
7805             }
7806             if (retarray)
7807                 return newRV_noinc(MUTABLE_SV(retarray));
7808         }
7809     }
7810     return NULL;
7811 }
7812
7813 bool
7814 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7815                            const U32 flags)
7816 {
7817     struct regexp *const rx = ReANY(r);
7818
7819     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7820
7821     if (rx && RXp_PAREN_NAMES(rx)) {
7822         if (flags & RXapif_ALL) {
7823             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7824         } else {
7825             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7826             if (sv) {
7827                 SvREFCNT_dec_NN(sv);
7828                 return TRUE;
7829             } else {
7830                 return FALSE;
7831             }
7832         }
7833     } else {
7834         return FALSE;
7835     }
7836 }
7837
7838 SV*
7839 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7840 {
7841     struct regexp *const rx = ReANY(r);
7842
7843     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7844
7845     if ( rx && RXp_PAREN_NAMES(rx) ) {
7846         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7847
7848         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7849     } else {
7850         return FALSE;
7851     }
7852 }
7853
7854 SV*
7855 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7856 {
7857     struct regexp *const rx = ReANY(r);
7858     GET_RE_DEBUG_FLAGS_DECL;
7859
7860     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7861
7862     if (rx && RXp_PAREN_NAMES(rx)) {
7863         HV *hv = RXp_PAREN_NAMES(rx);
7864         HE *temphe;
7865         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7866             IV i;
7867             IV parno = 0;
7868             SV* sv_dat = HeVAL(temphe);
7869             I32 *nums = (I32*)SvPVX(sv_dat);
7870             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7871                 if ((I32)(rx->lastparen) >= nums[i] &&
7872                     rx->offs[nums[i]].start != -1 &&
7873                     rx->offs[nums[i]].end != -1)
7874                 {
7875                     parno = nums[i];
7876                     break;
7877                 }
7878             }
7879             if (parno || flags & RXapif_ALL) {
7880                 return newSVhek(HeKEY_hek(temphe));
7881             }
7882         }
7883     }
7884     return NULL;
7885 }
7886
7887 SV*
7888 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
7889 {
7890     SV *ret;
7891     AV *av;
7892     SSize_t length;
7893     struct regexp *const rx = ReANY(r);
7894
7895     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
7896
7897     if (rx && RXp_PAREN_NAMES(rx)) {
7898         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
7899             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
7900         } else if (flags & RXapif_ONE) {
7901             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
7902             av = MUTABLE_AV(SvRV(ret));
7903             length = av_tindex(av);
7904             SvREFCNT_dec_NN(ret);
7905             return newSViv(length + 1);
7906         } else {
7907             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
7908                                                 (int)flags);
7909             return NULL;
7910         }
7911     }
7912     return &PL_sv_undef;
7913 }
7914
7915 SV*
7916 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
7917 {
7918     struct regexp *const rx = ReANY(r);
7919     AV *av = newAV();
7920
7921     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
7922
7923     if (rx && RXp_PAREN_NAMES(rx)) {
7924         HV *hv= RXp_PAREN_NAMES(rx);
7925         HE *temphe;
7926         (void)hv_iterinit(hv);
7927         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7928             IV i;
7929             IV parno = 0;
7930             SV* sv_dat = HeVAL(temphe);
7931             I32 *nums = (I32*)SvPVX(sv_dat);
7932             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7933                 if ((I32)(rx->lastparen) >= nums[i] &&
7934                     rx->offs[nums[i]].start != -1 &&
7935                     rx->offs[nums[i]].end != -1)
7936                 {
7937                     parno = nums[i];
7938                     break;
7939                 }
7940             }
7941             if (parno || flags & RXapif_ALL) {
7942                 av_push(av, newSVhek(HeKEY_hek(temphe)));
7943             }
7944         }
7945     }
7946
7947     return newRV_noinc(MUTABLE_SV(av));
7948 }
7949
7950 void
7951 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
7952                              SV * const sv)
7953 {
7954     struct regexp *const rx = ReANY(r);
7955     char *s = NULL;
7956     SSize_t i = 0;
7957     SSize_t s1, t1;
7958     I32 n = paren;
7959
7960     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
7961
7962     if (      n == RX_BUFF_IDX_CARET_PREMATCH
7963            || n == RX_BUFF_IDX_CARET_FULLMATCH
7964            || n == RX_BUFF_IDX_CARET_POSTMATCH
7965        )
7966     {
7967         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
7968         if (!keepcopy) {
7969             /* on something like
7970              *    $r = qr/.../;
7971              *    /$qr/p;
7972              * the KEEPCOPY is set on the PMOP rather than the regex */
7973             if (PL_curpm && r == PM_GETRE(PL_curpm))
7974                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
7975         }
7976         if (!keepcopy)
7977             goto ret_undef;
7978     }
7979
7980     if (!rx->subbeg)
7981         goto ret_undef;
7982
7983     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
7984         /* no need to distinguish between them any more */
7985         n = RX_BUFF_IDX_FULLMATCH;
7986
7987     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
7988         && rx->offs[0].start != -1)
7989     {
7990         /* $`, ${^PREMATCH} */
7991         i = rx->offs[0].start;
7992         s = rx->subbeg;
7993     }
7994     else
7995     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
7996         && rx->offs[0].end != -1)
7997     {
7998         /* $', ${^POSTMATCH} */
7999         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8000         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8001     }
8002     else
8003     if ( 0 <= n && n <= (I32)rx->nparens &&
8004         (s1 = rx->offs[n].start) != -1 &&
8005         (t1 = rx->offs[n].end) != -1)
8006     {
8007         /* $&, ${^MATCH},  $1 ... */
8008         i = t1 - s1;
8009         s = rx->subbeg + s1 - rx->suboffset;
8010     } else {
8011         goto ret_undef;
8012     }
8013
8014     assert(s >= rx->subbeg);
8015     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8016     if (i >= 0) {
8017 #ifdef NO_TAINT_SUPPORT
8018         sv_setpvn(sv, s, i);
8019 #else
8020         const int oldtainted = TAINT_get;
8021         TAINT_NOT;
8022         sv_setpvn(sv, s, i);
8023         TAINT_set(oldtainted);
8024 #endif
8025         if (RXp_MATCH_UTF8(rx))
8026             SvUTF8_on(sv);
8027         else
8028             SvUTF8_off(sv);
8029         if (TAINTING_get) {
8030             if (RXp_MATCH_TAINTED(rx)) {
8031                 if (SvTYPE(sv) >= SVt_PVMG) {
8032                     MAGIC* const mg = SvMAGIC(sv);
8033                     MAGIC* mgt;
8034                     TAINT;
8035                     SvMAGIC_set(sv, mg->mg_moremagic);
8036                     SvTAINT(sv);
8037                     if ((mgt = SvMAGIC(sv))) {
8038                         mg->mg_moremagic = mgt;
8039                         SvMAGIC_set(sv, mg);
8040                     }
8041                 } else {
8042                     TAINT;
8043                     SvTAINT(sv);
8044                 }
8045             } else
8046                 SvTAINTED_off(sv);
8047         }
8048     } else {
8049       ret_undef:
8050         sv_setsv(sv,&PL_sv_undef);
8051         return;
8052     }
8053 }
8054
8055 void
8056 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8057                                                          SV const * const value)
8058 {
8059     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8060
8061     PERL_UNUSED_ARG(rx);
8062     PERL_UNUSED_ARG(paren);
8063     PERL_UNUSED_ARG(value);
8064
8065     if (!PL_localizing)
8066         Perl_croak_no_modify();
8067 }
8068
8069 I32
8070 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8071                               const I32 paren)
8072 {
8073     struct regexp *const rx = ReANY(r);
8074     I32 i;
8075     I32 s1, t1;
8076
8077     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8078
8079     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8080         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8081         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8082     )
8083     {
8084         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8085         if (!keepcopy) {
8086             /* on something like
8087              *    $r = qr/.../;
8088              *    /$qr/p;
8089              * the KEEPCOPY is set on the PMOP rather than the regex */
8090             if (PL_curpm && r == PM_GETRE(PL_curpm))
8091                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8092         }
8093         if (!keepcopy)
8094             goto warn_undef;
8095     }
8096
8097     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8098     switch (paren) {
8099       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8100       case RX_BUFF_IDX_PREMATCH:       /* $` */
8101         if (rx->offs[0].start != -1) {
8102                         i = rx->offs[0].start;
8103                         if (i > 0) {
8104                                 s1 = 0;
8105                                 t1 = i;
8106                                 goto getlen;
8107                         }
8108             }
8109         return 0;
8110
8111       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8112       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8113             if (rx->offs[0].end != -1) {
8114                         i = rx->sublen - rx->offs[0].end;
8115                         if (i > 0) {
8116                                 s1 = rx->offs[0].end;
8117                                 t1 = rx->sublen;
8118                                 goto getlen;
8119                         }
8120             }
8121         return 0;
8122
8123       default: /* $& / ${^MATCH}, $1, $2, ... */
8124             if (paren <= (I32)rx->nparens &&
8125             (s1 = rx->offs[paren].start) != -1 &&
8126             (t1 = rx->offs[paren].end) != -1)
8127             {
8128             i = t1 - s1;
8129             goto getlen;
8130         } else {
8131           warn_undef:
8132             if (ckWARN(WARN_UNINITIALIZED))
8133                 report_uninit((const SV *)sv);
8134             return 0;
8135         }
8136     }
8137   getlen:
8138     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8139         const char * const s = rx->subbeg - rx->suboffset + s1;
8140         const U8 *ep;
8141         STRLEN el;
8142
8143         i = t1 - s1;
8144         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8145                         i = el;
8146     }
8147     return i;
8148 }
8149
8150 SV*
8151 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8152 {
8153     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8154         PERL_UNUSED_ARG(rx);
8155         if (0)
8156             return NULL;
8157         else
8158             return newSVpvs("Regexp");
8159 }
8160
8161 /* Scans the name of a named buffer from the pattern.
8162  * If flags is REG_RSN_RETURN_NULL returns null.
8163  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8164  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8165  * to the parsed name as looked up in the RExC_paren_names hash.
8166  * If there is an error throws a vFAIL().. type exception.
8167  */
8168
8169 #define REG_RSN_RETURN_NULL    0
8170 #define REG_RSN_RETURN_NAME    1
8171 #define REG_RSN_RETURN_DATA    2
8172
8173 STATIC SV*
8174 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8175 {
8176     char *name_start = RExC_parse;
8177
8178     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8179
8180     assert (RExC_parse <= RExC_end);
8181     if (RExC_parse == RExC_end) NOOP;
8182     else if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
8183          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8184           * using do...while */
8185         if (UTF)
8186             do {
8187                 RExC_parse += UTF8SKIP(RExC_parse);
8188             } while (isWORDCHAR_utf8((U8*)RExC_parse));
8189         else
8190             do {
8191                 RExC_parse++;
8192             } while (isWORDCHAR(*RExC_parse));
8193     } else {
8194         RExC_parse++; /* so the <- from the vFAIL is after the offending
8195                          character */
8196         vFAIL("Group name must start with a non-digit word character");
8197     }
8198     if ( flags ) {
8199         SV* sv_name
8200             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8201                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8202         if ( flags == REG_RSN_RETURN_NAME)
8203             return sv_name;
8204         else if (flags==REG_RSN_RETURN_DATA) {
8205             HE *he_str = NULL;
8206             SV *sv_dat = NULL;
8207             if ( ! sv_name )      /* should not happen*/
8208                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8209             if (RExC_paren_names)
8210                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8211             if ( he_str )
8212                 sv_dat = HeVAL(he_str);
8213             if ( ! sv_dat )
8214                 vFAIL("Reference to nonexistent named group");
8215             return sv_dat;
8216         }
8217         else {
8218             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8219                        (unsigned long) flags);
8220         }
8221         NOT_REACHED; /* NOTREACHED */
8222     }
8223     return NULL;
8224 }
8225
8226 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8227     int num;                                                    \
8228     if (RExC_lastparse!=RExC_parse) {                           \
8229         PerlIO_printf(Perl_debug_log, "%s",                     \
8230             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8231                 RExC_end - RExC_parse, 16,                      \
8232                 "", "",                                         \
8233                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8234                 PERL_PV_PRETTY_ELLIPSES   |                     \
8235                 PERL_PV_PRETTY_LTGT       |                     \
8236                 PERL_PV_ESCAPE_RE         |                     \
8237                 PERL_PV_PRETTY_EXACTSIZE                        \
8238             )                                                   \
8239         );                                                      \
8240     } else                                                      \
8241         PerlIO_printf(Perl_debug_log,"%16s","");                \
8242                                                                 \
8243     if (SIZE_ONLY)                                              \
8244        num = RExC_size + 1;                                     \
8245     else                                                        \
8246        num=REG_NODE_NUM(RExC_emit);                             \
8247     if (RExC_lastnum!=num)                                      \
8248        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
8249     else                                                        \
8250        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
8251     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
8252         (int)((depth*2)), "",                                   \
8253         (funcname)                                              \
8254     );                                                          \
8255     RExC_lastnum=num;                                           \
8256     RExC_lastparse=RExC_parse;                                  \
8257 })
8258
8259
8260
8261 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8262     DEBUG_PARSE_MSG((funcname));                            \
8263     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
8264 })
8265 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
8266     DEBUG_PARSE_MSG((funcname));                            \
8267     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
8268 })
8269
8270 /* This section of code defines the inversion list object and its methods.  The
8271  * interfaces are highly subject to change, so as much as possible is static to
8272  * this file.  An inversion list is here implemented as a malloc'd C UV array
8273  * as an SVt_INVLIST scalar.
8274  *
8275  * An inversion list for Unicode is an array of code points, sorted by ordinal
8276  * number.  The zeroth element is the first code point in the list.  The 1th
8277  * element is the first element beyond that not in the list.  In other words,
8278  * the first range is
8279  *  invlist[0]..(invlist[1]-1)
8280  * The other ranges follow.  Thus every element whose index is divisible by two
8281  * marks the beginning of a range that is in the list, and every element not
8282  * divisible by two marks the beginning of a range not in the list.  A single
8283  * element inversion list that contains the single code point N generally
8284  * consists of two elements
8285  *  invlist[0] == N
8286  *  invlist[1] == N+1
8287  * (The exception is when N is the highest representable value on the
8288  * machine, in which case the list containing just it would be a single
8289  * element, itself.  By extension, if the last range in the list extends to
8290  * infinity, then the first element of that range will be in the inversion list
8291  * at a position that is divisible by two, and is the final element in the
8292  * list.)
8293  * Taking the complement (inverting) an inversion list is quite simple, if the
8294  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8295  * This implementation reserves an element at the beginning of each inversion
8296  * list to always contain 0; there is an additional flag in the header which
8297  * indicates if the list begins at the 0, or is offset to begin at the next
8298  * element.
8299  *
8300  * More about inversion lists can be found in "Unicode Demystified"
8301  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8302  * More will be coming when functionality is added later.
8303  *
8304  * The inversion list data structure is currently implemented as an SV pointing
8305  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8306  * array of UV whose memory management is automatically handled by the existing
8307  * facilities for SV's.
8308  *
8309  * Some of the methods should always be private to the implementation, and some
8310  * should eventually be made public */
8311
8312 /* The header definitions are in F<invlist_inline.h> */
8313
8314 PERL_STATIC_INLINE UV*
8315 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8316 {
8317     /* Returns a pointer to the first element in the inversion list's array.
8318      * This is called upon initialization of an inversion list.  Where the
8319      * array begins depends on whether the list has the code point U+0000 in it
8320      * or not.  The other parameter tells it whether the code that follows this
8321      * call is about to put a 0 in the inversion list or not.  The first
8322      * element is either the element reserved for 0, if TRUE, or the element
8323      * after it, if FALSE */
8324
8325     bool* offset = get_invlist_offset_addr(invlist);
8326     UV* zero_addr = (UV *) SvPVX(invlist);
8327
8328     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8329
8330     /* Must be empty */
8331     assert(! _invlist_len(invlist));
8332
8333     *zero_addr = 0;
8334
8335     /* 1^1 = 0; 1^0 = 1 */
8336     *offset = 1 ^ will_have_0;
8337     return zero_addr + *offset;
8338 }
8339
8340 PERL_STATIC_INLINE void
8341 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8342 {
8343     /* Sets the current number of elements stored in the inversion list.
8344      * Updates SvCUR correspondingly */
8345     PERL_UNUSED_CONTEXT;
8346     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8347
8348     assert(SvTYPE(invlist) == SVt_INVLIST);
8349
8350     SvCUR_set(invlist,
8351               (len == 0)
8352                ? 0
8353                : TO_INTERNAL_SIZE(len + offset));
8354     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8355 }
8356
8357 #ifndef PERL_IN_XSUB_RE
8358
8359 STATIC void
8360 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8361 {
8362     /* Replaces the inversion list in 'src' with the one in 'dest'.  It steals
8363      * the list from 'src', so 'src' is made to have a NULL list.  This is
8364      * similar to what SvSetMagicSV() would do, if it were implemented on
8365      * inversion lists, though this routine avoids a copy */
8366
8367     const UV src_len          = _invlist_len(src);
8368     const bool src_offset     = *get_invlist_offset_addr(src);
8369     const STRLEN src_byte_len = SvLEN(src);
8370     char * array              = SvPVX(src);
8371
8372     const int oldtainted = TAINT_get;
8373
8374     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8375
8376     assert(SvTYPE(src) == SVt_INVLIST);
8377     assert(SvTYPE(dest) == SVt_INVLIST);
8378     assert(! invlist_is_iterating(src));
8379     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8380
8381     /* Make sure it ends in the right place with a NUL, as our inversion list
8382      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8383      * asserts it */
8384     array[src_byte_len - 1] = '\0';
8385
8386     TAINT_NOT;      /* Otherwise it breaks */
8387     sv_usepvn_flags(dest,
8388                     (char *) array,
8389                     src_byte_len - 1,
8390
8391                     /* This flag is documented to cause a copy to be avoided */
8392                     SV_HAS_TRAILING_NUL);
8393     TAINT_set(oldtainted);
8394     SvPV_set(src, 0);
8395     SvLEN_set(src, 0);
8396     SvCUR_set(src, 0);
8397
8398     /* Finish up copying over the other fields in an inversion list */
8399     *get_invlist_offset_addr(dest) = src_offset;
8400     invlist_set_len(dest, src_len, src_offset);
8401     *get_invlist_previous_index_addr(dest) = 0;
8402     invlist_iterfinish(dest);
8403 }
8404
8405 PERL_STATIC_INLINE IV*
8406 S_get_invlist_previous_index_addr(SV* invlist)
8407 {
8408     /* Return the address of the IV that is reserved to hold the cached index
8409      * */
8410     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8411
8412     assert(SvTYPE(invlist) == SVt_INVLIST);
8413
8414     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8415 }
8416
8417 PERL_STATIC_INLINE IV
8418 S_invlist_previous_index(SV* const invlist)
8419 {
8420     /* Returns cached index of previous search */
8421
8422     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8423
8424     return *get_invlist_previous_index_addr(invlist);
8425 }
8426
8427 PERL_STATIC_INLINE void
8428 S_invlist_set_previous_index(SV* const invlist, const IV index)
8429 {
8430     /* Caches <index> for later retrieval */
8431
8432     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8433
8434     assert(index == 0 || index < (int) _invlist_len(invlist));
8435
8436     *get_invlist_previous_index_addr(invlist) = index;
8437 }
8438
8439 PERL_STATIC_INLINE void
8440 S_invlist_trim(SV* invlist)
8441 {
8442     /* Free the not currently-being-used space in an inversion list */
8443
8444     /* But don't free up the space needed for 0 UV that is always at the
8445      * beginning of the list, nor the trailing NUL */
8446     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8447
8448     PERL_ARGS_ASSERT_INVLIST_TRIM;
8449
8450     assert(SvTYPE(invlist) == SVt_INVLIST);
8451
8452     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8453
8454 }
8455
8456 PERL_STATIC_INLINE void
8457 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8458 {
8459     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8460
8461     assert(SvTYPE(invlist) == SVt_INVLIST);
8462
8463     invlist_set_len(invlist, 0, 0);
8464     invlist_trim(invlist);
8465 }
8466
8467 #endif /* ifndef PERL_IN_XSUB_RE */
8468
8469 PERL_STATIC_INLINE bool
8470 S_invlist_is_iterating(SV* const invlist)
8471 {
8472     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8473
8474     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8475 }
8476
8477 PERL_STATIC_INLINE UV
8478 S_invlist_max(SV* const invlist)
8479 {
8480     /* Returns the maximum number of elements storable in the inversion list's
8481      * array, without having to realloc() */
8482
8483     PERL_ARGS_ASSERT_INVLIST_MAX;
8484
8485     assert(SvTYPE(invlist) == SVt_INVLIST);
8486
8487     /* Assumes worst case, in which the 0 element is not counted in the
8488      * inversion list, so subtracts 1 for that */
8489     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8490            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8491            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8492 }
8493
8494 #ifndef PERL_IN_XSUB_RE
8495 SV*
8496 Perl__new_invlist(pTHX_ IV initial_size)
8497 {
8498
8499     /* Return a pointer to a newly constructed inversion list, with enough
8500      * space to store 'initial_size' elements.  If that number is negative, a
8501      * system default is used instead */
8502
8503     SV* new_list;
8504
8505     if (initial_size < 0) {
8506         initial_size = 10;
8507     }
8508
8509     /* Allocate the initial space */
8510     new_list = newSV_type(SVt_INVLIST);
8511
8512     /* First 1 is in case the zero element isn't in the list; second 1 is for
8513      * trailing NUL */
8514     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8515     invlist_set_len(new_list, 0, 0);
8516
8517     /* Force iterinit() to be used to get iteration to work */
8518     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8519
8520     *get_invlist_previous_index_addr(new_list) = 0;
8521
8522     return new_list;
8523 }
8524
8525 SV*
8526 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8527 {
8528     /* Return a pointer to a newly constructed inversion list, initialized to
8529      * point to <list>, which has to be in the exact correct inversion list
8530      * form, including internal fields.  Thus this is a dangerous routine that
8531      * should not be used in the wrong hands.  The passed in 'list' contains
8532      * several header fields at the beginning that are not part of the
8533      * inversion list body proper */
8534
8535     const STRLEN length = (STRLEN) list[0];
8536     const UV version_id =          list[1];
8537     const bool offset   =    cBOOL(list[2]);
8538 #define HEADER_LENGTH 3
8539     /* If any of the above changes in any way, you must change HEADER_LENGTH
8540      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8541      *      perl -E 'say int(rand 2**31-1)'
8542      */
8543 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8544                                         data structure type, so that one being
8545                                         passed in can be validated to be an
8546                                         inversion list of the correct vintage.
8547                                        */
8548
8549     SV* invlist = newSV_type(SVt_INVLIST);
8550
8551     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8552
8553     if (version_id != INVLIST_VERSION_ID) {
8554         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8555     }
8556
8557     /* The generated array passed in includes header elements that aren't part
8558      * of the list proper, so start it just after them */
8559     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8560
8561     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8562                                shouldn't touch it */
8563
8564     *(get_invlist_offset_addr(invlist)) = offset;
8565
8566     /* The 'length' passed to us is the physical number of elements in the
8567      * inversion list.  But if there is an offset the logical number is one
8568      * less than that */
8569     invlist_set_len(invlist, length  - offset, offset);
8570
8571     invlist_set_previous_index(invlist, 0);
8572
8573     /* Initialize the iteration pointer. */
8574     invlist_iterfinish(invlist);
8575
8576     SvREADONLY_on(invlist);
8577
8578     return invlist;
8579 }
8580 #endif /* ifndef PERL_IN_XSUB_RE */
8581
8582 STATIC void
8583 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8584 {
8585     /* Grow the maximum size of an inversion list */
8586
8587     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8588
8589     assert(SvTYPE(invlist) == SVt_INVLIST);
8590
8591     /* Add one to account for the zero element at the beginning which may not
8592      * be counted by the calling parameters */
8593     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8594 }
8595
8596 STATIC void
8597 S__append_range_to_invlist(pTHX_ SV* const invlist,
8598                                  const UV start, const UV end)
8599 {
8600    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8601     * the end of the inversion list.  The range must be above any existing
8602     * ones. */
8603
8604     UV* array;
8605     UV max = invlist_max(invlist);
8606     UV len = _invlist_len(invlist);
8607     bool offset;
8608
8609     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8610
8611     if (len == 0) { /* Empty lists must be initialized */
8612         offset = start != 0;
8613         array = _invlist_array_init(invlist, ! offset);
8614     }
8615     else {
8616         /* Here, the existing list is non-empty. The current max entry in the
8617          * list is generally the first value not in the set, except when the
8618          * set extends to the end of permissible values, in which case it is
8619          * the first entry in that final set, and so this call is an attempt to
8620          * append out-of-order */
8621
8622         UV final_element = len - 1;
8623         array = invlist_array(invlist);
8624         if (array[final_element] > start
8625             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8626         {
8627             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",
8628                      array[final_element], start,
8629                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8630         }
8631
8632         /* Here, it is a legal append.  If the new range begins with the first
8633          * value not in the set, it is extending the set, so the new first
8634          * value not in the set is one greater than the newly extended range.
8635          * */
8636         offset = *get_invlist_offset_addr(invlist);
8637         if (array[final_element] == start) {
8638             if (end != UV_MAX) {
8639                 array[final_element] = end + 1;
8640             }
8641             else {
8642                 /* But if the end is the maximum representable on the machine,
8643                  * just let the range that this would extend to have no end */
8644                 invlist_set_len(invlist, len - 1, offset);
8645             }
8646             return;
8647         }
8648     }
8649
8650     /* Here the new range doesn't extend any existing set.  Add it */
8651
8652     len += 2;   /* Includes an element each for the start and end of range */
8653
8654     /* If wll overflow the existing space, extend, which may cause the array to
8655      * be moved */
8656     if (max < len) {
8657         invlist_extend(invlist, len);
8658
8659         /* Have to set len here to avoid assert failure in invlist_array() */
8660         invlist_set_len(invlist, len, offset);
8661
8662         array = invlist_array(invlist);
8663     }
8664     else {
8665         invlist_set_len(invlist, len, offset);
8666     }
8667
8668     /* The next item on the list starts the range, the one after that is
8669      * one past the new range.  */
8670     array[len - 2] = start;
8671     if (end != UV_MAX) {
8672         array[len - 1] = end + 1;
8673     }
8674     else {
8675         /* But if the end is the maximum representable on the machine, just let
8676          * the range have no end */
8677         invlist_set_len(invlist, len - 1, offset);
8678     }
8679 }
8680
8681 #ifndef PERL_IN_XSUB_RE
8682
8683 IV
8684 Perl__invlist_search(SV* const invlist, const UV cp)
8685 {
8686     /* Searches the inversion list for the entry that contains the input code
8687      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8688      * return value is the index into the list's array of the range that
8689      * contains <cp>, that is, 'i' such that
8690      *  array[i] <= cp < array[i+1]
8691      */
8692
8693     IV low = 0;
8694     IV mid;
8695     IV high = _invlist_len(invlist);
8696     const IV highest_element = high - 1;
8697     const UV* array;
8698
8699     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8700
8701     /* If list is empty, return failure. */
8702     if (high == 0) {
8703         return -1;
8704     }
8705
8706     /* (We can't get the array unless we know the list is non-empty) */
8707     array = invlist_array(invlist);
8708
8709     mid = invlist_previous_index(invlist);
8710     assert(mid >=0);
8711     if (mid > highest_element) {
8712         mid = highest_element;
8713     }
8714
8715     /* <mid> contains the cache of the result of the previous call to this
8716      * function (0 the first time).  See if this call is for the same result,
8717      * or if it is for mid-1.  This is under the theory that calls to this
8718      * function will often be for related code points that are near each other.
8719      * And benchmarks show that caching gives better results.  We also test
8720      * here if the code point is within the bounds of the list.  These tests
8721      * replace others that would have had to be made anyway to make sure that
8722      * the array bounds were not exceeded, and these give us extra information
8723      * at the same time */
8724     if (cp >= array[mid]) {
8725         if (cp >= array[highest_element]) {
8726             return highest_element;
8727         }
8728
8729         /* Here, array[mid] <= cp < array[highest_element].  This means that
8730          * the final element is not the answer, so can exclude it; it also
8731          * means that <mid> is not the final element, so can refer to 'mid + 1'
8732          * safely */
8733         if (cp < array[mid + 1]) {
8734             return mid;
8735         }
8736         high--;
8737         low = mid + 1;
8738     }
8739     else { /* cp < aray[mid] */
8740         if (cp < array[0]) { /* Fail if outside the array */
8741             return -1;
8742         }
8743         high = mid;
8744         if (cp >= array[mid - 1]) {
8745             goto found_entry;
8746         }
8747     }
8748
8749     /* Binary search.  What we are looking for is <i> such that
8750      *  array[i] <= cp < array[i+1]
8751      * The loop below converges on the i+1.  Note that there may not be an
8752      * (i+1)th element in the array, and things work nonetheless */
8753     while (low < high) {
8754         mid = (low + high) / 2;
8755         assert(mid <= highest_element);
8756         if (array[mid] <= cp) { /* cp >= array[mid] */
8757             low = mid + 1;
8758
8759             /* We could do this extra test to exit the loop early.
8760             if (cp < array[low]) {
8761                 return mid;
8762             }
8763             */
8764         }
8765         else { /* cp < array[mid] */
8766             high = mid;
8767         }
8768     }
8769
8770   found_entry:
8771     high--;
8772     invlist_set_previous_index(invlist, high);
8773     return high;
8774 }
8775
8776 void
8777 Perl__invlist_populate_swatch(SV* const invlist,
8778                               const UV start, const UV end, U8* swatch)
8779 {
8780     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8781      * but is used when the swash has an inversion list.  This makes this much
8782      * faster, as it uses a binary search instead of a linear one.  This is
8783      * intimately tied to that function, and perhaps should be in utf8.c,
8784      * except it is intimately tied to inversion lists as well.  It assumes
8785      * that <swatch> is all 0's on input */
8786
8787     UV current = start;
8788     const IV len = _invlist_len(invlist);
8789     IV i;
8790     const UV * array;
8791
8792     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8793
8794     if (len == 0) { /* Empty inversion list */
8795         return;
8796     }
8797
8798     array = invlist_array(invlist);
8799
8800     /* Find which element it is */
8801     i = _invlist_search(invlist, start);
8802
8803     /* We populate from <start> to <end> */
8804     while (current < end) {
8805         UV upper;
8806
8807         /* The inversion list gives the results for every possible code point
8808          * after the first one in the list.  Only those ranges whose index is
8809          * even are ones that the inversion list matches.  For the odd ones,
8810          * and if the initial code point is not in the list, we have to skip
8811          * forward to the next element */
8812         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8813             i++;
8814             if (i >= len) { /* Finished if beyond the end of the array */
8815                 return;
8816             }
8817             current = array[i];
8818             if (current >= end) {   /* Finished if beyond the end of what we
8819                                        are populating */
8820                 if (LIKELY(end < UV_MAX)) {
8821                     return;
8822                 }
8823
8824                 /* We get here when the upper bound is the maximum
8825                  * representable on the machine, and we are looking for just
8826                  * that code point.  Have to special case it */
8827                 i = len;
8828                 goto join_end_of_list;
8829             }
8830         }
8831         assert(current >= start);
8832
8833         /* The current range ends one below the next one, except don't go past
8834          * <end> */
8835         i++;
8836         upper = (i < len && array[i] < end) ? array[i] : end;
8837
8838         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8839          * for each code point in it */
8840         for (; current < upper; current++) {
8841             const STRLEN offset = (STRLEN)(current - start);
8842             swatch[offset >> 3] |= 1 << (offset & 7);
8843         }
8844
8845       join_end_of_list:
8846
8847         /* Quit if at the end of the list */
8848         if (i >= len) {
8849
8850             /* But first, have to deal with the highest possible code point on
8851              * the platform.  The previous code assumes that <end> is one
8852              * beyond where we want to populate, but that is impossible at the
8853              * platform's infinity, so have to handle it specially */
8854             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8855             {
8856                 const STRLEN offset = (STRLEN)(end - start);
8857                 swatch[offset >> 3] |= 1 << (offset & 7);
8858             }
8859             return;
8860         }
8861
8862         /* Advance to the next range, which will be for code points not in the
8863          * inversion list */
8864         current = array[i];
8865     }
8866
8867     return;
8868 }
8869
8870 void
8871 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8872                                          const bool complement_b, SV** output)
8873 {
8874     /* Take the union of two inversion lists and point <output> to it.  *output
8875      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8876      * the reference count to that list will be decremented if not already a
8877      * temporary (mortal); otherwise just its contents will be modified to be
8878      * the union.  The first list, <a>, may be NULL, in which case a copy of
8879      * the second list is returned.  If <complement_b> is TRUE, the union is
8880      * taken of the complement (inversion) of <b> instead of b itself.
8881      *
8882      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8883      * Richard Gillam, published by Addison-Wesley, and explained at some
8884      * length there.  The preface says to incorporate its examples into your
8885      * code at your own risk.
8886      *
8887      * The algorithm is like a merge sort.
8888      *
8889      * XXX A potential performance improvement is to keep track as we go along
8890      * if only one of the inputs contributes to the result, meaning the other
8891      * is a subset of that one.  In that case, we can skip the final copy and
8892      * return the larger of the input lists, but then outside code might need
8893      * to keep track of whether to free the input list or not */
8894
8895     const UV* array_a;    /* a's array */
8896     const UV* array_b;
8897     UV len_a;       /* length of a's array */
8898     UV len_b;
8899
8900     SV* u;                      /* the resulting union */
8901     UV* array_u;
8902     UV len_u;
8903
8904     UV i_a = 0;             /* current index into a's array */
8905     UV i_b = 0;
8906     UV i_u = 0;
8907
8908     /* running count, as explained in the algorithm source book; items are
8909      * stopped accumulating and are output when the count changes to/from 0.
8910      * The count is incremented when we start a range that's in the set, and
8911      * decremented when we start a range that's not in the set.  So its range
8912      * is 0 to 2.  Only when the count is zero is something not in the set.
8913      */
8914     UV count = 0;
8915
8916     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
8917     assert(a != b);
8918
8919     len_b = _invlist_len(b);
8920     if (len_b == 0) {
8921
8922         /* Here, 'b' is empty.  If the output is the complement of 'b', the
8923          * union is all possible code points, and we need not even look at 'a'.
8924          * It's easiest to create a new inversion list that matches everything.
8925          * */
8926         if (complement_b) {
8927             SV* everything = _new_invlist(1);
8928             _append_range_to_invlist(everything, 0, UV_MAX);
8929
8930             /* If the output didn't exist, just point it at the new list */
8931             if (*output == NULL) {
8932                 *output = everything;
8933                 return;
8934             }
8935
8936             /* Otherwise, replace its contents with the new list */
8937             invlist_replace_list_destroys_src(*output, everything);
8938             SvREFCNT_dec_NN(everything);
8939             return;
8940         }
8941
8942         /* Here, we don't want the complement of 'b', and since it is empty,
8943          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
8944          * output will be empty */
8945
8946         if (a == NULL) {
8947             *output = _new_invlist(0);
8948             return;
8949         }
8950
8951         if (_invlist_len(a) == 0) {
8952             invlist_clear(*output);
8953             return;
8954         }
8955
8956         /* Here, 'a' is not empty, and entirely determines the union.  If the
8957          * output is not to overwrite 'b', we can just return 'a'. */
8958         if (*output != b) {
8959
8960             /* If the output is to overwrite 'a', we have a no-op, as it's
8961              * already in 'a' */
8962             if (*output == a) {
8963                 return;
8964             }
8965
8966             /* But otherwise we have to copy 'a' to the output */
8967             *output = invlist_clone(a);
8968             return;
8969         }
8970
8971         /* Here, 'b' is to be overwritten by the output, which will be 'a' */
8972         u = invlist_clone(a);
8973         invlist_replace_list_destroys_src(*output, u);
8974         SvREFCNT_dec_NN(u);
8975
8976         return;
8977     }
8978
8979     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
8980
8981         /* Here, 'a' is empty.  That means the union will come entirely from
8982          * 'b'.  If the output is not to overwrite 'a', we can just return
8983          * what's in 'b'.  */
8984         if (*output != a) {
8985
8986             /* If the output is to overwrite 'b', it's already in 'b', but
8987              * otherwise we have to copy 'b' to the output */
8988             if (*output != b) {
8989                 *output = invlist_clone(b);
8990             }
8991
8992             /* And if the output is to be the inversion of 'b', do that */
8993             if (complement_b) {
8994                 _invlist_invert(*output);
8995             }
8996
8997             return;
8998         }
8999
9000         /* Here, 'a', which is empty or even NULL, is to be overwritten by the
9001          * output, which will either be 'b' or the complement of 'b' */
9002
9003         if (a == NULL) {
9004             *output = invlist_clone(b);
9005         }
9006         else {
9007             u = invlist_clone(b);
9008             invlist_replace_list_destroys_src(*output, u);
9009             SvREFCNT_dec_NN(u);
9010         }
9011
9012         if (complement_b) {
9013             _invlist_invert(*output);
9014         }
9015
9016         return;
9017     }
9018
9019     /* Here both lists exist and are non-empty */
9020     array_a = invlist_array(a);
9021     array_b = invlist_array(b);
9022
9023     /* If are to take the union of 'a' with the complement of b, set it
9024      * up so are looking at b's complement. */
9025     if (complement_b) {
9026
9027         /* To complement, we invert: if the first element is 0, remove it.  To
9028          * do this, we just pretend the array starts one later */
9029         if (array_b[0] == 0) {
9030             array_b++;
9031             len_b--;
9032         }
9033         else {
9034
9035             /* But if the first element is not zero, we pretend the list starts
9036              * at the 0 that is always stored immediately before the array. */
9037             array_b--;
9038             len_b++;
9039         }
9040     }
9041
9042     /* Size the union for the worst case: that the sets are completely
9043      * disjoint */
9044     u = _new_invlist(len_a + len_b);
9045
9046     /* Will contain U+0000 if either component does */
9047     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
9048                                       || (len_b > 0 && array_b[0] == 0));
9049
9050     /* Go through each list item by item, stopping when exhausted one of
9051      * them */
9052     while (i_a < len_a && i_b < len_b) {
9053         UV cp;      /* The element to potentially add to the union's array */
9054         bool cp_in_set;   /* is it in the the input list's set or not */
9055
9056         /* We need to take one or the other of the two inputs for the union.
9057          * Since we are merging two sorted lists, we take the smaller of the
9058          * next items.  In case of a tie, we take the one that is in its set
9059          * first.  If we took one not in the set first, it would decrement the
9060          * count, possibly to 0 which would cause it to be output as ending the
9061          * range, and the next time through we would take the same number, and
9062          * output it again as beginning the next range.  By doing it the
9063          * opposite way, there is no possibility that the count will be
9064          * momentarily decremented to 0, and thus the two adjoining ranges will
9065          * be seamlessly merged.  (In a tie and both are in the set or both not
9066          * in the set, it doesn't matter which we take first.) */
9067         if (array_a[i_a] < array_b[i_b]
9068             || (array_a[i_a] == array_b[i_b]
9069                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9070         {
9071             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9072             cp= array_a[i_a++];
9073         }
9074         else {
9075             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9076             cp = array_b[i_b++];
9077         }
9078
9079         /* Here, have chosen which of the two inputs to look at.  Only output
9080          * if the running count changes to/from 0, which marks the
9081          * beginning/end of a range in that's in the set */
9082         if (cp_in_set) {
9083             if (count == 0) {
9084                 array_u[i_u++] = cp;
9085             }
9086             count++;
9087         }
9088         else {
9089             count--;
9090             if (count == 0) {
9091                 array_u[i_u++] = cp;
9092             }
9093         }
9094     }
9095
9096     /* Here, we are finished going through at least one of the lists, which
9097      * means there is something remaining in at most one.  We check if the list
9098      * that hasn't been exhausted is positioned such that we are in the middle
9099      * of a range in its set or not.  (i_a and i_b point to the element beyond
9100      * the one we care about.) If in the set, we decrement 'count'; if 0, there
9101      * is potentially more to output.
9102      * There are four cases:
9103      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
9104      *     in the union is entirely from the non-exhausted set.
9105      *  2) Both were in their sets, count is 2.  Nothing further should
9106      *     be output, as everything that remains will be in the exhausted
9107      *     list's set, hence in the union; decrementing to 1 but not 0 insures
9108      *     that
9109      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
9110      *     Nothing further should be output because the union includes
9111      *     everything from the exhausted set.  Not decrementing ensures that.
9112      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
9113      *     decrementing to 0 insures that we look at the remainder of the
9114      *     non-exhausted set */
9115     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9116         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9117     {
9118         count--;
9119     }
9120
9121     /* The final length is what we've output so far, plus what else is about to
9122      * be output.  (If 'count' is non-zero, then the input list we exhausted
9123      * has everything remaining up to the machine's limit in its set, and hence
9124      * in the union, so there will be no further output. */
9125     len_u = i_u;
9126     if (count == 0) {
9127         /* At most one of the subexpressions will be non-zero */
9128         len_u += (len_a - i_a) + (len_b - i_b);
9129     }
9130
9131     /* Set result to final length, which can change the pointer to array_u, so
9132      * re-find it */
9133     if (len_u != _invlist_len(u)) {
9134         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9135         invlist_trim(u);
9136         array_u = invlist_array(u);
9137     }
9138
9139     /* When 'count' is 0, the list that was exhausted (if one was shorter than
9140      * the other) ended with everything above it not in its set.  That means
9141      * that the remaining part of the union is precisely the same as the
9142      * non-exhausted list, so can just copy it unchanged.  (If both list were
9143      * exhausted at the same time, then the operations below will be both 0.)
9144      */
9145     if (count == 0) {
9146         IV copy_count; /* At most one will have a non-zero copy count */
9147         if ((copy_count = len_a - i_a) > 0) {
9148             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9149         }
9150         else if ((copy_count = len_b - i_b) > 0) {
9151             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9152         }
9153     }
9154
9155     if (a != *output && b != *output) {
9156         *output = u;
9157     }
9158     else {
9159         /*  Here, the output is to be the same as one of the input scalars,
9160          *  hence replacing it.  The simple thing to do is to free the input
9161          *  scalar, making it instead be the output one.  But experience has
9162          *  shown [perl #127392] that if the input is a mortal, we can get a
9163          *  huge build-up of these during regex compilation before they get
9164          *  freed.  So for that case, replace just the input's interior with
9165          *  the output's, and then free the output */
9166
9167         assert(! invlist_is_iterating(*output));
9168
9169         if (! SvTEMP(*output)) {
9170             SvREFCNT_dec_NN(*output);
9171             *output = u;
9172         }
9173         else {
9174             invlist_replace_list_destroys_src(*output, u);
9175             SvREFCNT_dec_NN(u);
9176         }
9177     }
9178
9179     return;
9180 }
9181
9182 void
9183 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9184                                                const bool complement_b, SV** i)
9185 {
9186     /* Take the intersection of two inversion lists and point <i> to it.  *i
9187      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
9188      * the reference count to that list will be decremented if not already a
9189      * temporary (mortal); otherwise just its contents will be modified to be
9190      * the intersection.  The first list, <a>, may be NULL, in which case an
9191      * empty list is returned.  If <complement_b> is TRUE, the result will be
9192      * the intersection of <a> and the complement (or inversion) of <b> instead
9193      * of <b> directly.
9194      *
9195      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9196      * Richard Gillam, published by Addison-Wesley, and explained at some
9197      * length there.  The preface says to incorporate its examples into your
9198      * code at your own risk.  In fact, it had bugs
9199      *
9200      * The algorithm is like a merge sort, and is essentially the same as the
9201      * union above
9202      */
9203
9204     const UV* array_a;          /* a's array */
9205     const UV* array_b;
9206     UV len_a;   /* length of a's array */
9207     UV len_b;
9208
9209     SV* r;                   /* the resulting intersection */
9210     UV* array_r;
9211     UV len_r;
9212
9213     UV i_a = 0;             /* current index into a's array */
9214     UV i_b = 0;
9215     UV i_r = 0;
9216
9217     /* running count, as explained in the algorithm source book; items are
9218      * stopped accumulating and are output when the count changes to/from 2.
9219      * The count is incremented when we start a range that's in the set, and
9220      * decremented when we start a range that's not in the set.  So its range
9221      * is 0 to 2.  Only when the count is 2 is something in the intersection.
9222      */
9223     UV count = 0;
9224
9225     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9226     assert(a != b);
9227
9228     /* Special case if either one is empty */
9229     len_a = (a == NULL) ? 0 : _invlist_len(a);
9230     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9231         if (len_a != 0 && complement_b) {
9232
9233             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9234              * must be empty.  Here, also we are using 'b's complement, which
9235              * hence must be every possible code point.  Thus the intersection
9236              * is simply 'a'. */
9237
9238             if (*i == a) {  /* No-op */
9239                 return;
9240             }
9241
9242             /* If not overwriting either input, just make a copy of 'a' */
9243             if (*i != b) {
9244                 *i = invlist_clone(a);
9245                 return;
9246             }
9247
9248             /* Here we are overwriting 'b' with 'a's contents */
9249             r = invlist_clone(a);
9250             invlist_replace_list_destroys_src(*i, r);
9251             SvREFCNT_dec_NN(r);
9252             return;
9253         }
9254
9255         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9256          * intersection must be empty */
9257         if (*i == NULL) {
9258             *i = _new_invlist(0);
9259             return;
9260         }
9261
9262         invlist_clear(*i);
9263         return;
9264     }
9265
9266     /* Here both lists exist and are non-empty */
9267     array_a = invlist_array(a);
9268     array_b = invlist_array(b);
9269
9270     /* If are to take the intersection of 'a' with the complement of b, set it
9271      * up so are looking at b's complement. */
9272     if (complement_b) {
9273
9274         /* To complement, we invert: if the first element is 0, remove it.  To
9275          * do this, we just pretend the array starts one later */
9276         if (array_b[0] == 0) {
9277             array_b++;
9278             len_b--;
9279         }
9280         else {
9281
9282             /* But if the first element is not zero, we pretend the list starts
9283              * at the 0 that is always stored immediately before the array. */
9284             array_b--;
9285             len_b++;
9286         }
9287     }
9288
9289     /* Size the intersection for the worst case: that the intersection ends up
9290      * fragmenting everything to be completely disjoint */
9291     r= _new_invlist(len_a + len_b);
9292
9293     /* Will contain U+0000 iff both components do */
9294     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
9295                                      && len_b > 0 && array_b[0] == 0);
9296
9297     /* Go through each list item by item, stopping when exhausted one of
9298      * them */
9299     while (i_a < len_a && i_b < len_b) {
9300         UV cp;      /* The element to potentially add to the intersection's
9301                        array */
9302         bool cp_in_set; /* Is it in the input list's set or not */
9303
9304         /* We need to take one or the other of the two inputs for the
9305          * intersection.  Since we are merging two sorted lists, we take the
9306          * smaller of the next items.  In case of a tie, we take the one that
9307          * is not in its set first (a difference from the union algorithm).  If
9308          * we took one in the set first, it would increment the count, possibly
9309          * to 2 which would cause it to be output as starting a range in the
9310          * intersection, and the next time through we would take that same
9311          * number, and output it again as ending the set.  By doing it the
9312          * opposite of this, there is no possibility that the count will be
9313          * momentarily incremented to 2.  (In a tie and both are in the set or
9314          * both not in the set, it doesn't matter which we take first.) */
9315         if (array_a[i_a] < array_b[i_b]
9316             || (array_a[i_a] == array_b[i_b]
9317                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9318         {
9319             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9320             cp= array_a[i_a++];
9321         }
9322         else {
9323             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9324             cp= array_b[i_b++];
9325         }
9326
9327         /* Here, have chosen which of the two inputs to look at.  Only output
9328          * if the running count changes to/from 2, which marks the
9329          * beginning/end of a range that's in the intersection */
9330         if (cp_in_set) {
9331             count++;
9332             if (count == 2) {
9333                 array_r[i_r++] = cp;
9334             }
9335         }
9336         else {
9337             if (count == 2) {
9338                 array_r[i_r++] = cp;
9339             }
9340             count--;
9341         }
9342     }
9343
9344     /* Here, we are finished going through at least one of the lists, which
9345      * means there is something remaining in at most one.  We check if the list
9346      * that has been exhausted is positioned such that we are in the middle
9347      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
9348      * the ones we care about.)  There are four cases:
9349      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
9350      *     nothing left in the intersection.
9351      *  2) Both were in their sets, count is 2 and perhaps is incremented to
9352      *     above 2.  What should be output is exactly that which is in the
9353      *     non-exhausted set, as everything it has is also in the intersection
9354      *     set, and everything it doesn't have can't be in the intersection
9355      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
9356      *     gets incremented to 2.  Like the previous case, the intersection is
9357      *     everything that remains in the non-exhausted set.
9358      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
9359      *     remains 1.  And the intersection has nothing more. */
9360     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9361         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9362     {
9363         count++;
9364     }
9365
9366     /* The final length is what we've output so far plus what else is in the
9367      * intersection.  At most one of the subexpressions below will be non-zero
9368      * */
9369     len_r = i_r;
9370     if (count >= 2) {
9371         len_r += (len_a - i_a) + (len_b - i_b);
9372     }
9373
9374     /* Set result to final length, which can change the pointer to array_r, so
9375      * re-find it */
9376     if (len_r != _invlist_len(r)) {
9377         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9378         invlist_trim(r);
9379         array_r = invlist_array(r);
9380     }
9381
9382     /* Finish outputting any remaining */
9383     if (count >= 2) { /* At most one will have a non-zero copy count */
9384         IV copy_count;
9385         if ((copy_count = len_a - i_a) > 0) {
9386             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9387         }
9388         else if ((copy_count = len_b - i_b) > 0) {
9389             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9390         }
9391     }
9392
9393     if (a != *i && b != *i) {
9394         *i = r;
9395     }
9396     else {
9397         /*  Here, the output is to be the same as one of the input scalars,
9398          *  hence replacing it.  The simple thing to do is to free the input
9399          *  scalar, making it instead be the output one.  But experience has
9400          *  shown [perl #127392] that if the input is a mortal, we can get a
9401          *  huge build-up of these during regex compilation before they get
9402          *  freed.  So for that case, replace just the input's interior with
9403          *  the output's, and then free the output.  A short-cut in this case
9404          *  is if the output is empty, we can just set the input to be empty */
9405
9406         assert(! invlist_is_iterating(*i));
9407
9408         if (! SvTEMP(*i)) {
9409             SvREFCNT_dec_NN(*i);
9410             *i = r;
9411         }
9412         else {
9413             if (len_r) {
9414                 invlist_replace_list_destroys_src(*i, r);
9415             }
9416             else {
9417                 invlist_clear(*i);
9418             }
9419             SvREFCNT_dec_NN(r);
9420         }
9421     }
9422
9423     return;
9424 }
9425
9426 SV*
9427 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
9428 {
9429     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9430      * set.  A pointer to the inversion list is returned.  This may actually be
9431      * a new list, in which case the passed in one has been destroyed.  The
9432      * passed-in inversion list can be NULL, in which case a new one is created
9433      * with just the one range in it */
9434
9435     SV* range_invlist;
9436     UV len;
9437
9438     if (invlist == NULL) {
9439         invlist = _new_invlist(2);
9440         len = 0;
9441     }
9442     else {
9443         len = _invlist_len(invlist);
9444     }
9445
9446     /* If comes after the final entry actually in the list, can just append it
9447      * to the end, */
9448     if (len == 0
9449         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
9450             && start >= invlist_array(invlist)[len - 1]))
9451     {
9452         _append_range_to_invlist(invlist, start, end);
9453         return invlist;
9454     }
9455
9456     /* Here, can't just append things, create and return a new inversion list
9457      * which is the union of this range and the existing inversion list.  (If
9458      * the new range is well-behaved wrt to the old one, we could just insert
9459      * it, doing a Move() down on the tail of the old one (potentially growing
9460      * it first).  But to determine that means we would have the extra
9461      * (possibly throw-away) work of first finding where the new one goes and
9462      * whether it disrupts (splits) an existing range, so it doesn't appear to
9463      * me (khw) that it's worth it) */
9464     range_invlist = _new_invlist(2);
9465     _append_range_to_invlist(range_invlist, start, end);
9466
9467     _invlist_union(invlist, range_invlist, &invlist);
9468
9469     /* The temporary can be freed */
9470     SvREFCNT_dec_NN(range_invlist);
9471
9472     return invlist;
9473 }
9474
9475 SV*
9476 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9477                                  UV** other_elements_ptr)
9478 {
9479     /* Create and return an inversion list whose contents are to be populated
9480      * by the caller.  The caller gives the number of elements (in 'size') and
9481      * the very first element ('element0').  This function will set
9482      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9483      * are to be placed.
9484      *
9485      * Obviously there is some trust involved that the caller will properly
9486      * fill in the other elements of the array.
9487      *
9488      * (The first element needs to be passed in, as the underlying code does
9489      * things differently depending on whether it is zero or non-zero) */
9490
9491     SV* invlist = _new_invlist(size);
9492     bool offset;
9493
9494     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9495
9496     _append_range_to_invlist(invlist, element0, element0);
9497     offset = *get_invlist_offset_addr(invlist);
9498
9499     invlist_set_len(invlist, size, offset);
9500     *other_elements_ptr = invlist_array(invlist) + 1;
9501     return invlist;
9502 }
9503
9504 #endif
9505
9506 PERL_STATIC_INLINE SV*
9507 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9508     return _add_range_to_invlist(invlist, cp, cp);
9509 }
9510
9511 #ifndef PERL_IN_XSUB_RE
9512 void
9513 Perl__invlist_invert(pTHX_ SV* const invlist)
9514 {
9515     /* Complement the input inversion list.  This adds a 0 if the list didn't
9516      * have a zero; removes it otherwise.  As described above, the data
9517      * structure is set up so that this is very efficient */
9518
9519     PERL_ARGS_ASSERT__INVLIST_INVERT;
9520
9521     assert(! invlist_is_iterating(invlist));
9522
9523     /* The inverse of matching nothing is matching everything */
9524     if (_invlist_len(invlist) == 0) {
9525         _append_range_to_invlist(invlist, 0, UV_MAX);
9526         return;
9527     }
9528
9529     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9530 }
9531
9532 #endif
9533
9534 PERL_STATIC_INLINE SV*
9535 S_invlist_clone(pTHX_ SV* const invlist)
9536 {
9537
9538     /* Return a new inversion list that is a copy of the input one, which is
9539      * unchanged.  The new list will not be mortal even if the old one was. */
9540
9541     /* Need to allocate extra space to accommodate Perl's addition of a
9542      * trailing NUL to SvPV's, since it thinks they are always strings */
9543     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9544     STRLEN physical_length = SvCUR(invlist);
9545     bool offset = *(get_invlist_offset_addr(invlist));
9546
9547     PERL_ARGS_ASSERT_INVLIST_CLONE;
9548
9549     *(get_invlist_offset_addr(new_invlist)) = offset;
9550     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9551     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9552
9553     return new_invlist;
9554 }
9555
9556 PERL_STATIC_INLINE STRLEN*
9557 S_get_invlist_iter_addr(SV* invlist)
9558 {
9559     /* Return the address of the UV that contains the current iteration
9560      * position */
9561
9562     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9563
9564     assert(SvTYPE(invlist) == SVt_INVLIST);
9565
9566     return &(((XINVLIST*) SvANY(invlist))->iterator);
9567 }
9568
9569 PERL_STATIC_INLINE void
9570 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9571 {
9572     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9573
9574     *get_invlist_iter_addr(invlist) = 0;
9575 }
9576
9577 PERL_STATIC_INLINE void
9578 S_invlist_iterfinish(SV* invlist)
9579 {
9580     /* Terminate iterator for invlist.  This is to catch development errors.
9581      * Any iteration that is interrupted before completed should call this
9582      * function.  Functions that add code points anywhere else but to the end
9583      * of an inversion list assert that they are not in the middle of an
9584      * iteration.  If they were, the addition would make the iteration
9585      * problematical: if the iteration hadn't reached the place where things
9586      * were being added, it would be ok */
9587
9588     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9589
9590     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9591 }
9592
9593 STATIC bool
9594 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9595 {
9596     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9597      * This call sets in <*start> and <*end>, the next range in <invlist>.
9598      * Returns <TRUE> if successful and the next call will return the next
9599      * range; <FALSE> if was already at the end of the list.  If the latter,
9600      * <*start> and <*end> are unchanged, and the next call to this function
9601      * will start over at the beginning of the list */
9602
9603     STRLEN* pos = get_invlist_iter_addr(invlist);
9604     UV len = _invlist_len(invlist);
9605     UV *array;
9606
9607     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9608
9609     if (*pos >= len) {
9610         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9611         return FALSE;
9612     }
9613
9614     array = invlist_array(invlist);
9615
9616     *start = array[(*pos)++];
9617
9618     if (*pos >= len) {
9619         *end = UV_MAX;
9620     }
9621     else {
9622         *end = array[(*pos)++] - 1;
9623     }
9624
9625     return TRUE;
9626 }
9627
9628 PERL_STATIC_INLINE UV
9629 S_invlist_highest(SV* const invlist)
9630 {
9631     /* Returns the highest code point that matches an inversion list.  This API
9632      * has an ambiguity, as it returns 0 under either the highest is actually
9633      * 0, or if the list is empty.  If this distinction matters to you, check
9634      * for emptiness before calling this function */
9635
9636     UV len = _invlist_len(invlist);
9637     UV *array;
9638
9639     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9640
9641     if (len == 0) {
9642         return 0;
9643     }
9644
9645     array = invlist_array(invlist);
9646
9647     /* The last element in the array in the inversion list always starts a
9648      * range that goes to infinity.  That range may be for code points that are
9649      * matched in the inversion list, or it may be for ones that aren't
9650      * matched.  In the latter case, the highest code point in the set is one
9651      * less than the beginning of this range; otherwise it is the final element
9652      * of this range: infinity */
9653     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9654            ? UV_MAX
9655            : array[len - 1] - 1;
9656 }
9657
9658 STATIC SV *
9659 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
9660 {
9661     /* Get the contents of an inversion list into a string SV so that they can
9662      * be printed out.  If 'traditional_style' is TRUE, it uses the format
9663      * traditionally done for debug tracing; otherwise it uses a format
9664      * suitable for just copying to the output, with blanks between ranges and
9665      * a dash between range components */
9666
9667     UV start, end;
9668     SV* output;
9669     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
9670     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
9671
9672     if (traditional_style) {
9673         output = newSVpvs("\n");
9674     }
9675     else {
9676         output = newSVpvs("");
9677     }
9678
9679     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
9680
9681     assert(! invlist_is_iterating(invlist));
9682
9683     invlist_iterinit(invlist);
9684     while (invlist_iternext(invlist, &start, &end)) {
9685         if (end == UV_MAX) {
9686             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"%cINFINITY%c",
9687                                           start, intra_range_delimiter,
9688                                                  inter_range_delimiter);
9689         }
9690         else if (end != start) {
9691             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"%c%04"UVXf"%c",
9692                                           start,
9693                                                    intra_range_delimiter,
9694                                                   end, inter_range_delimiter);
9695         }
9696         else {
9697             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"%c",
9698                                           start, inter_range_delimiter);
9699         }
9700     }
9701
9702     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
9703         SvCUR_set(output, SvCUR(output) - 1);
9704     }
9705
9706     return output;
9707 }
9708
9709 #ifndef PERL_IN_XSUB_RE
9710 void
9711 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
9712                          const char * const indent, SV* const invlist)
9713 {
9714     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
9715      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
9716      * the string 'indent'.  The output looks like this:
9717          [0] 0x000A .. 0x000D
9718          [2] 0x0085
9719          [4] 0x2028 .. 0x2029
9720          [6] 0x3104 .. INFINITY
9721      * This means that the first range of code points matched by the list are
9722      * 0xA through 0xD; the second range contains only the single code point
9723      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
9724      * are used to define each range (except if the final range extends to
9725      * infinity, only a single element is needed).  The array index of the
9726      * first element for the corresponding range is given in brackets. */
9727
9728     UV start, end;
9729     STRLEN count = 0;
9730
9731     PERL_ARGS_ASSERT__INVLIST_DUMP;
9732
9733     if (invlist_is_iterating(invlist)) {
9734         Perl_dump_indent(aTHX_ level, file,
9735              "%sCan't dump inversion list because is in middle of iterating\n",
9736              indent);
9737         return;
9738     }
9739
9740     invlist_iterinit(invlist);
9741     while (invlist_iternext(invlist, &start, &end)) {
9742         if (end == UV_MAX) {
9743             Perl_dump_indent(aTHX_ level, file,
9744                                        "%s[%"UVuf"] 0x%04"UVXf" .. INFINITY\n",
9745                                    indent, (UV)count, start);
9746         }
9747         else if (end != start) {
9748             Perl_dump_indent(aTHX_ level, file,
9749                                     "%s[%"UVuf"] 0x%04"UVXf" .. 0x%04"UVXf"\n",
9750                                 indent, (UV)count, start,         end);
9751         }
9752         else {
9753             Perl_dump_indent(aTHX_ level, file, "%s[%"UVuf"] 0x%04"UVXf"\n",
9754                                             indent, (UV)count, start);
9755         }
9756         count += 2;
9757     }
9758 }
9759
9760 void
9761 Perl__load_PL_utf8_foldclosures (pTHX)
9762 {
9763     assert(! PL_utf8_foldclosures);
9764
9765     /* If the folds haven't been read in, call a fold function
9766      * to force that */
9767     if (! PL_utf8_tofold) {
9768         U8 dummy[UTF8_MAXBYTES_CASE+1];
9769
9770         /* This string is just a short named one above \xff */
9771         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
9772         assert(PL_utf8_tofold); /* Verify that worked */
9773     }
9774     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
9775 }
9776 #endif
9777
9778 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
9779 bool
9780 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
9781 {
9782     /* Return a boolean as to if the two passed in inversion lists are
9783      * identical.  The final argument, if TRUE, says to take the complement of
9784      * the second inversion list before doing the comparison */
9785
9786     const UV* array_a = invlist_array(a);
9787     const UV* array_b = invlist_array(b);
9788     UV len_a = _invlist_len(a);
9789     UV len_b = _invlist_len(b);
9790
9791     UV i = 0;               /* current index into the arrays */
9792     bool retval = TRUE;     /* Assume are identical until proven otherwise */
9793
9794     PERL_ARGS_ASSERT__INVLISTEQ;
9795
9796     /* If are to compare 'a' with the complement of b, set it
9797      * up so are looking at b's complement. */
9798     if (complement_b) {
9799
9800         /* The complement of nothing is everything, so <a> would have to have
9801          * just one element, starting at zero (ending at infinity) */
9802         if (len_b == 0) {
9803             return (len_a == 1 && array_a[0] == 0);
9804         }
9805         else if (array_b[0] == 0) {
9806
9807             /* Otherwise, to complement, we invert.  Here, the first element is
9808              * 0, just remove it.  To do this, we just pretend the array starts
9809              * one later */
9810
9811             array_b++;
9812             len_b--;
9813         }
9814         else {
9815
9816             /* But if the first element is not zero, we pretend the list starts
9817              * at the 0 that is always stored immediately before the array. */
9818             array_b--;
9819             len_b++;
9820         }
9821     }
9822
9823     /* Make sure that the lengths are the same, as well as the final element
9824      * before looping through the remainder.  (Thus we test the length, final,
9825      * and first elements right off the bat) */
9826     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
9827         retval = FALSE;
9828     }
9829     else for (i = 0; i < len_a - 1; i++) {
9830         if (array_a[i] != array_b[i]) {
9831             retval = FALSE;
9832             break;
9833         }
9834     }
9835
9836     return retval;
9837 }
9838 #endif
9839
9840 /*
9841  * As best we can, determine the characters that can match the start of
9842  * the given EXACTF-ish node.
9843  *
9844  * Returns the invlist as a new SV*; it is the caller's responsibility to
9845  * call SvREFCNT_dec() when done with it.
9846  */
9847 STATIC SV*
9848 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
9849 {
9850     const U8 * s = (U8*)STRING(node);
9851     SSize_t bytelen = STR_LEN(node);
9852     UV uc;
9853     /* Start out big enough for 2 separate code points */
9854     SV* invlist = _new_invlist(4);
9855
9856     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
9857
9858     if (! UTF) {
9859         uc = *s;
9860
9861         /* We punt and assume can match anything if the node begins
9862          * with a multi-character fold.  Things are complicated.  For
9863          * example, /ffi/i could match any of:
9864          *  "\N{LATIN SMALL LIGATURE FFI}"
9865          *  "\N{LATIN SMALL LIGATURE FF}I"
9866          *  "F\N{LATIN SMALL LIGATURE FI}"
9867          *  plus several other things; and making sure we have all the
9868          *  possibilities is hard. */
9869         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
9870             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
9871         }
9872         else {
9873             /* Any Latin1 range character can potentially match any
9874              * other depending on the locale */
9875             if (OP(node) == EXACTFL) {
9876                 _invlist_union(invlist, PL_Latin1, &invlist);
9877             }
9878             else {
9879                 /* But otherwise, it matches at least itself.  We can
9880                  * quickly tell if it has a distinct fold, and if so,
9881                  * it matches that as well */
9882                 invlist = add_cp_to_invlist(invlist, uc);
9883                 if (IS_IN_SOME_FOLD_L1(uc))
9884                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
9885             }
9886
9887             /* Some characters match above-Latin1 ones under /i.  This
9888              * is true of EXACTFL ones when the locale is UTF-8 */
9889             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
9890                 && (! isASCII(uc) || (OP(node) != EXACTFA
9891                                     && OP(node) != EXACTFA_NO_TRIE)))
9892             {
9893                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
9894             }
9895         }
9896     }
9897     else {  /* Pattern is UTF-8 */
9898         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
9899         STRLEN foldlen = UTF8SKIP(s);
9900         const U8* e = s + bytelen;
9901         SV** listp;
9902
9903         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
9904
9905         /* The only code points that aren't folded in a UTF EXACTFish
9906          * node are are the problematic ones in EXACTFL nodes */
9907         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
9908             /* We need to check for the possibility that this EXACTFL
9909              * node begins with a multi-char fold.  Therefore we fold
9910              * the first few characters of it so that we can make that
9911              * check */
9912             U8 *d = folded;
9913             int i;
9914
9915             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
9916                 if (isASCII(*s)) {
9917                     *(d++) = (U8) toFOLD(*s);
9918                     s++;
9919                 }
9920                 else {
9921                     STRLEN len;
9922                     to_utf8_fold(s, d, &len);
9923                     d += len;
9924                     s += UTF8SKIP(s);
9925                 }
9926             }
9927
9928             /* And set up so the code below that looks in this folded
9929              * buffer instead of the node's string */
9930             e = d;
9931             foldlen = UTF8SKIP(folded);
9932             s = folded;
9933         }
9934
9935         /* When we reach here 's' points to the fold of the first
9936          * character(s) of the node; and 'e' points to far enough along
9937          * the folded string to be just past any possible multi-char
9938          * fold. 'foldlen' is the length in bytes of the first
9939          * character in 's'
9940          *
9941          * Unlike the non-UTF-8 case, the macro for determining if a
9942          * string is a multi-char fold requires all the characters to
9943          * already be folded.  This is because of all the complications
9944          * if not.  Note that they are folded anyway, except in EXACTFL
9945          * nodes.  Like the non-UTF case above, we punt if the node
9946          * begins with a multi-char fold  */
9947
9948         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
9949             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
9950         }
9951         else {  /* Single char fold */
9952
9953             /* It matches all the things that fold to it, which are
9954              * found in PL_utf8_foldclosures (including itself) */
9955             invlist = add_cp_to_invlist(invlist, uc);
9956             if (! PL_utf8_foldclosures)
9957                 _load_PL_utf8_foldclosures();
9958             if ((listp = hv_fetch(PL_utf8_foldclosures,
9959                                 (char *) s, foldlen, FALSE)))
9960             {
9961                 AV* list = (AV*) *listp;
9962                 IV k;
9963                 for (k = 0; k <= av_tindex(list); k++) {
9964                     SV** c_p = av_fetch(list, k, FALSE);
9965                     UV c;
9966                     assert(c_p);
9967
9968                     c = SvUV(*c_p);
9969
9970                     /* /aa doesn't allow folds between ASCII and non- */
9971                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
9972                         && isASCII(c) != isASCII(uc))
9973                     {
9974                         continue;
9975                     }
9976
9977                     invlist = add_cp_to_invlist(invlist, c);
9978                 }
9979             }
9980         }
9981     }
9982
9983     return invlist;
9984 }
9985
9986 #undef HEADER_LENGTH
9987 #undef TO_INTERNAL_SIZE
9988 #undef FROM_INTERNAL_SIZE
9989 #undef INVLIST_VERSION_ID
9990
9991 /* End of inversion list object */
9992
9993 STATIC void
9994 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
9995 {
9996     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
9997      * constructs, and updates RExC_flags with them.  On input, RExC_parse
9998      * should point to the first flag; it is updated on output to point to the
9999      * final ')' or ':'.  There needs to be at least one flag, or this will
10000      * abort */
10001
10002     /* for (?g), (?gc), and (?o) warnings; warning
10003        about (?c) will warn about (?g) -- japhy    */
10004
10005 #define WASTED_O  0x01
10006 #define WASTED_G  0x02
10007 #define WASTED_C  0x04
10008 #define WASTED_GC (WASTED_G|WASTED_C)
10009     I32 wastedflags = 0x00;
10010     U32 posflags = 0, negflags = 0;
10011     U32 *flagsp = &posflags;
10012     char has_charset_modifier = '\0';
10013     regex_charset cs;
10014     bool has_use_defaults = FALSE;
10015     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10016     int x_mod_count = 0;
10017
10018     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10019
10020     /* '^' as an initial flag sets certain defaults */
10021     if (UCHARAT(RExC_parse) == '^') {
10022         RExC_parse++;
10023         has_use_defaults = TRUE;
10024         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10025         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10026                                         ? REGEX_UNICODE_CHARSET
10027                                         : REGEX_DEPENDS_CHARSET);
10028     }
10029
10030     cs = get_regex_charset(RExC_flags);
10031     if (cs == REGEX_DEPENDS_CHARSET
10032         && (RExC_utf8 || RExC_uni_semantics))
10033     {
10034         cs = REGEX_UNICODE_CHARSET;
10035     }
10036
10037     while (RExC_parse < RExC_end) {
10038         /* && strchr("iogcmsx", *RExC_parse) */
10039         /* (?g), (?gc) and (?o) are useless here
10040            and must be globally applied -- japhy */
10041         switch (*RExC_parse) {
10042
10043             /* Code for the imsxn flags */
10044             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10045
10046             case LOCALE_PAT_MOD:
10047                 if (has_charset_modifier) {
10048                     goto excess_modifier;
10049                 }
10050                 else if (flagsp == &negflags) {
10051                     goto neg_modifier;
10052                 }
10053                 cs = REGEX_LOCALE_CHARSET;
10054                 has_charset_modifier = LOCALE_PAT_MOD;
10055                 break;
10056             case UNICODE_PAT_MOD:
10057                 if (has_charset_modifier) {
10058                     goto excess_modifier;
10059                 }
10060                 else if (flagsp == &negflags) {
10061                     goto neg_modifier;
10062                 }
10063                 cs = REGEX_UNICODE_CHARSET;
10064                 has_charset_modifier = UNICODE_PAT_MOD;
10065                 break;
10066             case ASCII_RESTRICT_PAT_MOD:
10067                 if (flagsp == &negflags) {
10068                     goto neg_modifier;
10069                 }
10070                 if (has_charset_modifier) {
10071                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10072                         goto excess_modifier;
10073                     }
10074                     /* Doubled modifier implies more restricted */
10075                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10076                 }
10077                 else {
10078                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10079                 }
10080                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10081                 break;
10082             case DEPENDS_PAT_MOD:
10083                 if (has_use_defaults) {
10084                     goto fail_modifiers;
10085                 }
10086                 else if (flagsp == &negflags) {
10087                     goto neg_modifier;
10088                 }
10089                 else if (has_charset_modifier) {
10090                     goto excess_modifier;
10091                 }
10092
10093                 /* The dual charset means unicode semantics if the
10094                  * pattern (or target, not known until runtime) are
10095                  * utf8, or something in the pattern indicates unicode
10096                  * semantics */
10097                 cs = (RExC_utf8 || RExC_uni_semantics)
10098                      ? REGEX_UNICODE_CHARSET
10099                      : REGEX_DEPENDS_CHARSET;
10100                 has_charset_modifier = DEPENDS_PAT_MOD;
10101                 break;
10102               excess_modifier:
10103                 RExC_parse++;
10104                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10105                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10106                 }
10107                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10108                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10109                                         *(RExC_parse - 1));
10110                 }
10111                 else {
10112                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10113                 }
10114                 NOT_REACHED; /*NOTREACHED*/
10115               neg_modifier:
10116                 RExC_parse++;
10117                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10118                                     *(RExC_parse - 1));
10119                 NOT_REACHED; /*NOTREACHED*/
10120             case ONCE_PAT_MOD: /* 'o' */
10121             case GLOBAL_PAT_MOD: /* 'g' */
10122                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10123                     const I32 wflagbit = *RExC_parse == 'o'
10124                                          ? WASTED_O
10125                                          : WASTED_G;
10126                     if (! (wastedflags & wflagbit) ) {
10127                         wastedflags |= wflagbit;
10128                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10129                         vWARN5(
10130                             RExC_parse + 1,
10131                             "Useless (%s%c) - %suse /%c modifier",
10132                             flagsp == &negflags ? "?-" : "?",
10133                             *RExC_parse,
10134                             flagsp == &negflags ? "don't " : "",
10135                             *RExC_parse
10136                         );
10137                     }
10138                 }
10139                 break;
10140
10141             case CONTINUE_PAT_MOD: /* 'c' */
10142                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10143                     if (! (wastedflags & WASTED_C) ) {
10144                         wastedflags |= WASTED_GC;
10145                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10146                         vWARN3(
10147                             RExC_parse + 1,
10148                             "Useless (%sc) - %suse /gc modifier",
10149                             flagsp == &negflags ? "?-" : "?",
10150                             flagsp == &negflags ? "don't " : ""
10151                         );
10152                     }
10153                 }
10154                 break;
10155             case KEEPCOPY_PAT_MOD: /* 'p' */
10156                 if (flagsp == &negflags) {
10157                     if (PASS2)
10158                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10159                 } else {
10160                     *flagsp |= RXf_PMf_KEEPCOPY;
10161                 }
10162                 break;
10163             case '-':
10164                 /* A flag is a default iff it is following a minus, so
10165                  * if there is a minus, it means will be trying to
10166                  * re-specify a default which is an error */
10167                 if (has_use_defaults || flagsp == &negflags) {
10168                     goto fail_modifiers;
10169                 }
10170                 flagsp = &negflags;
10171                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10172                 break;
10173             case ':':
10174             case ')':
10175                 RExC_flags |= posflags;
10176                 RExC_flags &= ~negflags;
10177                 set_regex_charset(&RExC_flags, cs);
10178                 if (RExC_flags & RXf_PMf_FOLD) {
10179                     RExC_contains_i = 1;
10180                 }
10181                 if (PASS2) {
10182                     STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
10183                 }
10184                 return;
10185                 /*NOTREACHED*/
10186             default:
10187               fail_modifiers:
10188                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10189                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10190                 vFAIL2utf8f("Sequence (%"UTF8f"...) not recognized",
10191                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10192                 NOT_REACHED; /*NOTREACHED*/
10193         }
10194
10195         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10196     }
10197
10198     vFAIL("Sequence (?... not terminated");
10199 }
10200
10201 /*
10202  - reg - regular expression, i.e. main body or parenthesized thing
10203  *
10204  * Caller must absorb opening parenthesis.
10205  *
10206  * Combining parenthesis handling with the base level of regular expression
10207  * is a trifle forced, but the need to tie the tails of the branches to what
10208  * follows makes it hard to avoid.
10209  */
10210 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10211 #ifdef DEBUGGING
10212 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10213 #else
10214 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10215 #endif
10216
10217 PERL_STATIC_INLINE regnode *
10218 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10219                              I32 *flagp,
10220                              char * parse_start,
10221                              char ch
10222                       )
10223 {
10224     regnode *ret;
10225     char* name_start = RExC_parse;
10226     U32 num = 0;
10227     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10228                                             ? REG_RSN_RETURN_NULL
10229                                             : REG_RSN_RETURN_DATA);
10230     GET_RE_DEBUG_FLAGS_DECL;
10231
10232     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10233
10234     if (RExC_parse == name_start || *RExC_parse != ch) {
10235         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10236         vFAIL2("Sequence %.3s... not terminated",parse_start);
10237     }
10238
10239     if (!SIZE_ONLY) {
10240         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10241         RExC_rxi->data->data[num]=(void*)sv_dat;
10242         SvREFCNT_inc_simple_void(sv_dat);
10243     }
10244     RExC_sawback = 1;
10245     ret = reganode(pRExC_state,
10246                    ((! FOLD)
10247                      ? NREF
10248                      : (ASCII_FOLD_RESTRICTED)
10249                        ? NREFFA
10250                        : (AT_LEAST_UNI_SEMANTICS)
10251                          ? NREFFU
10252                          : (LOC)
10253                            ? NREFFL
10254                            : NREFF),
10255                     num);
10256     *flagp |= HASWIDTH;
10257
10258     Set_Node_Offset(ret, parse_start+1);
10259     Set_Node_Cur_Length(ret, parse_start);
10260
10261     nextchar(pRExC_state);
10262     return ret;
10263 }
10264
10265 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10266    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10267    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10268    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10269    NULL, which cannot happen.  */
10270 STATIC regnode *
10271 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10272     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10273      * 2 is like 1, but indicates that nextchar() has been called to advance
10274      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10275      * this flag alerts us to the need to check for that */
10276 {
10277     regnode *ret;               /* Will be the head of the group. */
10278     regnode *br;
10279     regnode *lastbr;
10280     regnode *ender = NULL;
10281     I32 parno = 0;
10282     I32 flags;
10283     U32 oregflags = RExC_flags;
10284     bool have_branch = 0;
10285     bool is_open = 0;
10286     I32 freeze_paren = 0;
10287     I32 after_freeze = 0;
10288     I32 num; /* numeric backreferences */
10289
10290     char * parse_start = RExC_parse; /* MJD */
10291     char * const oregcomp_parse = RExC_parse;
10292
10293     GET_RE_DEBUG_FLAGS_DECL;
10294
10295     PERL_ARGS_ASSERT_REG;
10296     DEBUG_PARSE("reg ");
10297
10298     *flagp = 0;                         /* Tentatively. */
10299
10300     /* Having this true makes it feasible to have a lot fewer tests for the
10301      * parse pointer being in scope.  For example, we can write
10302      *      while(isFOO(*RExC_parse)) RExC_parse++;
10303      * instead of
10304      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10305      */
10306     assert(*RExC_end == '\0');
10307
10308     /* Make an OPEN node, if parenthesized. */
10309     if (paren) {
10310
10311         /* Under /x, space and comments can be gobbled up between the '(' and
10312          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10313          * intervening space, as the sequence is a token, and a token should be
10314          * indivisible */
10315         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
10316
10317         assert(RExC_parse < RExC_end);
10318
10319         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
10320             char *start_verb = RExC_parse + 1;
10321             STRLEN verb_len;
10322             char *start_arg = NULL;
10323             unsigned char op = 0;
10324             int arg_required = 0;
10325             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10326
10327             if (has_intervening_patws) {
10328                 RExC_parse++;   /* past the '*' */
10329                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10330             }
10331             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10332                 if ( *RExC_parse == ':' ) {
10333                     start_arg = RExC_parse + 1;
10334                     break;
10335                 }
10336                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10337             }
10338             verb_len = RExC_parse - start_verb;
10339             if ( start_arg ) {
10340                 if (RExC_parse >= RExC_end) {
10341                     goto unterminated_verb_pattern;
10342                 }
10343                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10344                 while ( RExC_parse < RExC_end && *RExC_parse != ')' )
10345                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10346                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10347                   unterminated_verb_pattern:
10348                     vFAIL("Unterminated verb pattern argument");
10349                 if ( RExC_parse == start_arg )
10350                     start_arg = NULL;
10351             } else {
10352                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10353                     vFAIL("Unterminated verb pattern");
10354             }
10355
10356             /* Here, we know that RExC_parse < RExC_end */
10357
10358             switch ( *start_verb ) {
10359             case 'A':  /* (*ACCEPT) */
10360                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10361                     op = ACCEPT;
10362                     internal_argval = RExC_nestroot;
10363                 }
10364                 break;
10365             case 'C':  /* (*COMMIT) */
10366                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10367                     op = COMMIT;
10368                 break;
10369             case 'F':  /* (*FAIL) */
10370                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10371                     op = OPFAIL;
10372                 }
10373                 break;
10374             case ':':  /* (*:NAME) */
10375             case 'M':  /* (*MARK:NAME) */
10376                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10377                     op = MARKPOINT;
10378                     arg_required = 1;
10379                 }
10380                 break;
10381             case 'P':  /* (*PRUNE) */
10382                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10383                     op = PRUNE;
10384                 break;
10385             case 'S':   /* (*SKIP) */
10386                 if ( memEQs(start_verb,verb_len,"SKIP") )
10387                     op = SKIP;
10388                 break;
10389             case 'T':  /* (*THEN) */
10390                 /* [19:06] <TimToady> :: is then */
10391                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10392                     op = CUTGROUP;
10393                     RExC_seen |= REG_CUTGROUP_SEEN;
10394                 }
10395                 break;
10396             }
10397             if ( ! op ) {
10398                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10399                 vFAIL2utf8f(
10400                     "Unknown verb pattern '%"UTF8f"'",
10401                     UTF8fARG(UTF, verb_len, start_verb));
10402             }
10403             if ( arg_required && !start_arg ) {
10404                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
10405                     verb_len, start_verb);
10406             }
10407             if (internal_argval == -1) {
10408                 ret = reganode(pRExC_state, op, 0);
10409             } else {
10410                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
10411             }
10412             RExC_seen |= REG_VERBARG_SEEN;
10413             if ( ! SIZE_ONLY ) {
10414                 if (start_arg) {
10415                     SV *sv = newSVpvn( start_arg,
10416                                        RExC_parse - start_arg);
10417                     ARG(ret) = add_data( pRExC_state,
10418                                          STR_WITH_LEN("S"));
10419                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
10420                     ret->flags = 1;
10421                 } else {
10422                     ret->flags = 0;
10423                 }
10424                 if ( internal_argval != -1 )
10425                     ARG2L_SET(ret, internal_argval);
10426             }
10427             nextchar(pRExC_state);
10428             return ret;
10429         }
10430         else if (*RExC_parse == '?') { /* (?...) */
10431             bool is_logical = 0;
10432             const char * const seqstart = RExC_parse;
10433             const char * endptr;
10434             if (has_intervening_patws) {
10435                 RExC_parse++;
10436                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
10437             }
10438
10439             RExC_parse++;           /* past the '?' */
10440             paren = *RExC_parse;    /* might be a trailing NUL, if not
10441                                        well-formed */
10442             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10443             if (RExC_parse > RExC_end) {
10444                 paren = '\0';
10445             }
10446             ret = NULL;                 /* For look-ahead/behind. */
10447             switch (paren) {
10448
10449             case 'P':   /* (?P...) variants for those used to PCRE/Python */
10450                 paren = *RExC_parse;
10451                 if ( paren == '<') {    /* (?P<...>) named capture */
10452                     RExC_parse++;
10453                     if (RExC_parse >= RExC_end) {
10454                         vFAIL("Sequence (?P<... not terminated");
10455                     }
10456                     goto named_capture;
10457                 }
10458                 else if (paren == '>') {   /* (?P>name) named recursion */
10459                     RExC_parse++;
10460                     if (RExC_parse >= RExC_end) {
10461                         vFAIL("Sequence (?P>... not terminated");
10462                     }
10463                     goto named_recursion;
10464                 }
10465                 else if (paren == '=') {   /* (?P=...)  named backref */
10466                     RExC_parse++;
10467                     return handle_named_backref(pRExC_state, flagp,
10468                                                 parse_start, ')');
10469                 }
10470                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10471                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10472                 vFAIL3("Sequence (%.*s...) not recognized",
10473                                 RExC_parse-seqstart, seqstart);
10474                 NOT_REACHED; /*NOTREACHED*/
10475             case '<':           /* (?<...) */
10476                 if (*RExC_parse == '!')
10477                     paren = ',';
10478                 else if (*RExC_parse != '=')
10479               named_capture:
10480                 {               /* (?<...>) */
10481                     char *name_start;
10482                     SV *svname;
10483                     paren= '>';
10484                 /* FALLTHROUGH */
10485             case '\'':          /* (?'...') */
10486                     name_start = RExC_parse;
10487                     svname = reg_scan_name(pRExC_state,
10488                         SIZE_ONLY    /* reverse test from the others */
10489                         ? REG_RSN_RETURN_NAME
10490                         : REG_RSN_RETURN_NULL);
10491                     if (   RExC_parse == name_start
10492                         || RExC_parse >= RExC_end
10493                         || *RExC_parse != paren)
10494                     {
10495                         vFAIL2("Sequence (?%c... not terminated",
10496                             paren=='>' ? '<' : paren);
10497                     }
10498                     if (SIZE_ONLY) {
10499                         HE *he_str;
10500                         SV *sv_dat = NULL;
10501                         if (!svname) /* shouldn't happen */
10502                             Perl_croak(aTHX_
10503                                 "panic: reg_scan_name returned NULL");
10504                         if (!RExC_paren_names) {
10505                             RExC_paren_names= newHV();
10506                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10507 #ifdef DEBUGGING
10508                             RExC_paren_name_list= newAV();
10509                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10510 #endif
10511                         }
10512                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10513                         if ( he_str )
10514                             sv_dat = HeVAL(he_str);
10515                         if ( ! sv_dat ) {
10516                             /* croak baby croak */
10517                             Perl_croak(aTHX_
10518                                 "panic: paren_name hash element allocation failed");
10519                         } else if ( SvPOK(sv_dat) ) {
10520                             /* (?|...) can mean we have dupes so scan to check
10521                                its already been stored. Maybe a flag indicating
10522                                we are inside such a construct would be useful,
10523                                but the arrays are likely to be quite small, so
10524                                for now we punt -- dmq */
10525                             IV count = SvIV(sv_dat);
10526                             I32 *pv = (I32*)SvPVX(sv_dat);
10527                             IV i;
10528                             for ( i = 0 ; i < count ; i++ ) {
10529                                 if ( pv[i] == RExC_npar ) {
10530                                     count = 0;
10531                                     break;
10532                                 }
10533                             }
10534                             if ( count ) {
10535                                 pv = (I32*)SvGROW(sv_dat,
10536                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10537                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10538                                 pv[count] = RExC_npar;
10539                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10540                             }
10541                         } else {
10542                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10543                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10544                                                                 sizeof(I32));
10545                             SvIOK_on(sv_dat);
10546                             SvIV_set(sv_dat, 1);
10547                         }
10548 #ifdef DEBUGGING
10549                         /* Yes this does cause a memory leak in debugging Perls
10550                          * */
10551                         if (!av_store(RExC_paren_name_list,
10552                                       RExC_npar, SvREFCNT_inc(svname)))
10553                             SvREFCNT_dec_NN(svname);
10554 #endif
10555
10556                         /*sv_dump(sv_dat);*/
10557                     }
10558                     nextchar(pRExC_state);
10559                     paren = 1;
10560                     goto capturing_parens;
10561                 }
10562                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10563                 RExC_in_lookbehind++;
10564                 RExC_parse++;
10565                 assert(RExC_parse < RExC_end);
10566                 /* FALLTHROUGH */
10567             case '=':           /* (?=...) */
10568                 RExC_seen_zerolen++;
10569                 break;
10570             case '!':           /* (?!...) */
10571                 RExC_seen_zerolen++;
10572                 /* check if we're really just a "FAIL" assertion */
10573                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
10574                                         FALSE /* Don't force to /x */ );
10575                 if (*RExC_parse == ')') {
10576                     ret=reganode(pRExC_state, OPFAIL, 0);
10577                     nextchar(pRExC_state);
10578                     return ret;
10579                 }
10580                 break;
10581             case '|':           /* (?|...) */
10582                 /* branch reset, behave like a (?:...) except that
10583                    buffers in alternations share the same numbers */
10584                 paren = ':';
10585                 after_freeze = freeze_paren = RExC_npar;
10586                 break;
10587             case ':':           /* (?:...) */
10588             case '>':           /* (?>...) */
10589                 break;
10590             case '$':           /* (?$...) */
10591             case '@':           /* (?@...) */
10592                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10593                 break;
10594             case '0' :           /* (?0) */
10595             case 'R' :           /* (?R) */
10596                 if (*RExC_parse != ')')
10597                     FAIL("Sequence (?R) not terminated");
10598                 ret = reg_node(pRExC_state, GOSTART);
10599                     RExC_seen |= REG_GOSTART_SEEN;
10600                 *flagp |= POSTPONED;
10601                 nextchar(pRExC_state);
10602                 return ret;
10603                 /*notreached*/
10604             /* named and numeric backreferences */
10605             case '&':            /* (?&NAME) */
10606                 parse_start = RExC_parse - 1;
10607               named_recursion:
10608                 {
10609                     SV *sv_dat = reg_scan_name(pRExC_state,
10610                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10611                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10612                 }
10613                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
10614                     vFAIL("Sequence (?&... not terminated");
10615                 goto gen_recurse_regop;
10616                 /* NOTREACHED */
10617             case '+':
10618                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10619                     RExC_parse++;
10620                     vFAIL("Illegal pattern");
10621                 }
10622                 goto parse_recursion;
10623                 /* NOTREACHED*/
10624             case '-': /* (?-1) */
10625                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10626                     RExC_parse--; /* rewind to let it be handled later */
10627                     goto parse_flags;
10628                 }
10629                 /* FALLTHROUGH */
10630             case '1': case '2': case '3': case '4': /* (?1) */
10631             case '5': case '6': case '7': case '8': case '9':
10632                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
10633               parse_recursion:
10634                 {
10635                     bool is_neg = FALSE;
10636                     UV unum;
10637                     parse_start = RExC_parse - 1; /* MJD */
10638                     if (*RExC_parse == '-') {
10639                         RExC_parse++;
10640                         is_neg = TRUE;
10641                     }
10642                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10643                         && unum <= I32_MAX
10644                     ) {
10645                         num = (I32)unum;
10646                         RExC_parse = (char*)endptr;
10647                     } else
10648                         num = I32_MAX;
10649                     if (is_neg) {
10650                         /* Some limit for num? */
10651                         num = -num;
10652                     }
10653                 }
10654                 if (*RExC_parse!=')')
10655                     vFAIL("Expecting close bracket");
10656
10657               gen_recurse_regop:
10658                 if ( paren == '-' ) {
10659                     /*
10660                     Diagram of capture buffer numbering.
10661                     Top line is the normal capture buffer numbers
10662                     Bottom line is the negative indexing as from
10663                     the X (the (?-2))
10664
10665                     +   1 2    3 4 5 X          6 7
10666                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
10667                     -   5 4    3 2 1 X          x x
10668
10669                     */
10670                     num = RExC_npar + num;
10671                     if (num < 1)  {
10672                         RExC_parse++;
10673                         vFAIL("Reference to nonexistent group");
10674                     }
10675                 } else if ( paren == '+' ) {
10676                     num = RExC_npar + num - 1;
10677                 }
10678
10679                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
10680                 if (!SIZE_ONLY) {
10681                     if (num > (I32)RExC_rx->nparens) {
10682                         RExC_parse++;
10683                         vFAIL("Reference to nonexistent group");
10684                     }
10685                     RExC_recurse_count++;
10686                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10687                         "%*s%*s Recurse #%"UVuf" to %"IVdf"\n",
10688                               22, "|    |", (int)(depth * 2 + 1), "",
10689                               (UV)ARG(ret), (IV)ARG2L(ret)));
10690                 }
10691                 RExC_seen |= REG_RECURSE_SEEN;
10692                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
10693                 Set_Node_Offset(ret, parse_start); /* MJD */
10694
10695                 *flagp |= POSTPONED;
10696                 nextchar(pRExC_state);
10697                 return ret;
10698
10699             /* NOTREACHED */
10700
10701             case '?':           /* (??...) */
10702                 is_logical = 1;
10703                 if (*RExC_parse != '{') {
10704                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
10705                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10706                     vFAIL2utf8f(
10707                         "Sequence (%"UTF8f"...) not recognized",
10708                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10709                     NOT_REACHED; /*NOTREACHED*/
10710                 }
10711                 *flagp |= POSTPONED;
10712                 paren = '{';
10713                 RExC_parse++;
10714                 /* FALLTHROUGH */
10715             case '{':           /* (?{...}) */
10716             {
10717                 U32 n = 0;
10718                 struct reg_code_block *cb;
10719
10720                 RExC_seen_zerolen++;
10721
10722                 if (   !pRExC_state->num_code_blocks
10723                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
10724                     || pRExC_state->code_blocks[pRExC_state->code_index].start
10725                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
10726                             - RExC_start)
10727                 ) {
10728                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
10729                         FAIL("panic: Sequence (?{...}): no code block found\n");
10730                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
10731                 }
10732                 /* this is a pre-compiled code block (?{...}) */
10733                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
10734                 RExC_parse = RExC_start + cb->end;
10735                 if (!SIZE_ONLY) {
10736                     OP *o = cb->block;
10737                     if (cb->src_regex) {
10738                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
10739                         RExC_rxi->data->data[n] =
10740                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
10741                         RExC_rxi->data->data[n+1] = (void*)o;
10742                     }
10743                     else {
10744                         n = add_data(pRExC_state,
10745                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
10746                         RExC_rxi->data->data[n] = (void*)o;
10747                     }
10748                 }
10749                 pRExC_state->code_index++;
10750                 nextchar(pRExC_state);
10751
10752                 if (is_logical) {
10753                     regnode *eval;
10754                     ret = reg_node(pRExC_state, LOGICAL);
10755
10756                     eval = reg2Lanode(pRExC_state, EVAL,
10757                                        n,
10758
10759                                        /* for later propagation into (??{})
10760                                         * return value */
10761                                        RExC_flags & RXf_PMf_COMPILETIME
10762                                       );
10763                     if (!SIZE_ONLY) {
10764                         ret->flags = 2;
10765                     }
10766                     REGTAIL(pRExC_state, ret, eval);
10767                     /* deal with the length of this later - MJD */
10768                     return ret;
10769                 }
10770                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
10771                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
10772                 Set_Node_Offset(ret, parse_start);
10773                 return ret;
10774             }
10775             case '(':           /* (?(?{...})...) and (?(?=...)...) */
10776             {
10777                 int is_define= 0;
10778                 const int DEFINE_len = sizeof("DEFINE") - 1;
10779                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
10780                     if (   RExC_parse < RExC_end - 1
10781                         && (   RExC_parse[1] == '='
10782                             || RExC_parse[1] == '!'
10783                             || RExC_parse[1] == '<'
10784                             || RExC_parse[1] == '{')
10785                     ) { /* Lookahead or eval. */
10786                         I32 flag;
10787                         regnode *tail;
10788
10789                         ret = reg_node(pRExC_state, LOGICAL);
10790                         if (!SIZE_ONLY)
10791                             ret->flags = 1;
10792
10793                         tail = reg(pRExC_state, 1, &flag, depth+1);
10794                         if (flag & (RESTART_PASS1|NEED_UTF8)) {
10795                             *flagp = flag & (RESTART_PASS1|NEED_UTF8);
10796                             return NULL;
10797                         }
10798                         REGTAIL(pRExC_state, ret, tail);
10799                         goto insert_if;
10800                     }
10801                     /* Fall through to ‘Unknown switch condition’ at the
10802                        end of the if/else chain. */
10803                 }
10804                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
10805                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
10806                 {
10807                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
10808                     char *name_start= RExC_parse++;
10809                     U32 num = 0;
10810                     SV *sv_dat=reg_scan_name(pRExC_state,
10811                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10812                     if (   RExC_parse == name_start
10813                         || RExC_parse >= RExC_end
10814                         || *RExC_parse != ch)
10815                     {
10816                         vFAIL2("Sequence (?(%c... not terminated",
10817                             (ch == '>' ? '<' : ch));
10818                     }
10819                     RExC_parse++;
10820                     if (!SIZE_ONLY) {
10821                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10822                         RExC_rxi->data->data[num]=(void*)sv_dat;
10823                         SvREFCNT_inc_simple_void(sv_dat);
10824                     }
10825                     ret = reganode(pRExC_state,NGROUPP,num);
10826                     goto insert_if_check_paren;
10827                 }
10828                 else if (RExC_end - RExC_parse >= DEFINE_len
10829                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
10830                 {
10831                     ret = reganode(pRExC_state,DEFINEP,0);
10832                     RExC_parse += DEFINE_len;
10833                     is_define = 1;
10834                     goto insert_if_check_paren;
10835                 }
10836                 else if (RExC_parse[0] == 'R') {
10837                     RExC_parse++;
10838                     parno = 0;
10839                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10840                         UV uv;
10841                         if (grok_atoUV(RExC_parse, &uv, &endptr)
10842                             && uv <= I32_MAX
10843                         ) {
10844                             parno = (I32)uv;
10845                             RExC_parse = (char*)endptr;
10846                         }
10847                         /* else "Switch condition not recognized" below */
10848                     } else if (RExC_parse[0] == '&') {
10849                         SV *sv_dat;
10850                         RExC_parse++;
10851                         sv_dat = reg_scan_name(pRExC_state,
10852                             SIZE_ONLY
10853                             ? REG_RSN_RETURN_NULL
10854                             : REG_RSN_RETURN_DATA);
10855                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10856                     }
10857                     ret = reganode(pRExC_state,INSUBP,parno);
10858                     goto insert_if_check_paren;
10859                 }
10860                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10861                     /* (?(1)...) */
10862                     char c;
10863                     UV uv;
10864                     if (grok_atoUV(RExC_parse, &uv, &endptr)
10865                         && uv <= I32_MAX
10866                     ) {
10867                         parno = (I32)uv;
10868                         RExC_parse = (char*)endptr;
10869                     }
10870                     else {
10871                         vFAIL("panic: grok_atoUV returned FALSE");
10872                     }
10873                     ret = reganode(pRExC_state, GROUPP, parno);
10874
10875                  insert_if_check_paren:
10876                     if (UCHARAT(RExC_parse) != ')') {
10877                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10878                         vFAIL("Switch condition not recognized");
10879                     }
10880                     nextchar(pRExC_state);
10881                   insert_if:
10882                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
10883                     br = regbranch(pRExC_state, &flags, 1,depth+1);
10884                     if (br == NULL) {
10885                         if (flags & (RESTART_PASS1|NEED_UTF8)) {
10886                             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
10887                             return NULL;
10888                         }
10889                         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10890                               (UV) flags);
10891                     } else
10892                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
10893                                                           LONGJMP, 0));
10894                     c = UCHARAT(RExC_parse);
10895                     nextchar(pRExC_state);
10896                     if (flags&HASWIDTH)
10897                         *flagp |= HASWIDTH;
10898                     if (c == '|') {
10899                         if (is_define)
10900                             vFAIL("(?(DEFINE)....) does not allow branches");
10901
10902                         /* Fake one for optimizer.  */
10903                         lastbr = reganode(pRExC_state, IFTHEN, 0);
10904
10905                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
10906                             if (flags & (RESTART_PASS1|NEED_UTF8)) {
10907                                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
10908                                 return NULL;
10909                             }
10910                             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10911                                   (UV) flags);
10912                         }
10913                         REGTAIL(pRExC_state, ret, lastbr);
10914                         if (flags&HASWIDTH)
10915                             *flagp |= HASWIDTH;
10916                         c = UCHARAT(RExC_parse);
10917                         nextchar(pRExC_state);
10918                     }
10919                     else
10920                         lastbr = NULL;
10921                     if (c != ')') {
10922                         if (RExC_parse >= RExC_end)
10923                             vFAIL("Switch (?(condition)... not terminated");
10924                         else
10925                             vFAIL("Switch (?(condition)... contains too many branches");
10926                     }
10927                     ender = reg_node(pRExC_state, TAIL);
10928                     REGTAIL(pRExC_state, br, ender);
10929                     if (lastbr) {
10930                         REGTAIL(pRExC_state, lastbr, ender);
10931                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
10932                     }
10933                     else
10934                         REGTAIL(pRExC_state, ret, ender);
10935                     RExC_size++; /* XXX WHY do we need this?!!
10936                                     For large programs it seems to be required
10937                                     but I can't figure out why. -- dmq*/
10938                     return ret;
10939                 }
10940                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10941                 vFAIL("Unknown switch condition (?(...))");
10942             }
10943             case '[':           /* (?[ ... ]) */
10944                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
10945                                          oregcomp_parse);
10946             case 0: /* A NUL */
10947                 RExC_parse--; /* for vFAIL to print correctly */
10948                 vFAIL("Sequence (? incomplete");
10949                 break;
10950             default: /* e.g., (?i) */
10951                 RExC_parse = (char *) seqstart + 1;
10952               parse_flags:
10953                 parse_lparen_question_flags(pRExC_state);
10954                 if (UCHARAT(RExC_parse) != ':') {
10955                     if (RExC_parse < RExC_end)
10956                         nextchar(pRExC_state);
10957                     *flagp = TRYAGAIN;
10958                     return NULL;
10959                 }
10960                 paren = ':';
10961                 nextchar(pRExC_state);
10962                 ret = NULL;
10963                 goto parse_rest;
10964             } /* end switch */
10965         }
10966         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
10967           capturing_parens:
10968             parno = RExC_npar;
10969             RExC_npar++;
10970
10971             ret = reganode(pRExC_state, OPEN, parno);
10972             if (!SIZE_ONLY ){
10973                 if (!RExC_nestroot)
10974                     RExC_nestroot = parno;
10975                 if (RExC_seen & REG_RECURSE_SEEN
10976                     && !RExC_open_parens[parno-1])
10977                 {
10978                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10979                         "%*s%*s Setting open paren #%"IVdf" to %d\n",
10980                         22, "|    |", (int)(depth * 2 + 1), "",
10981                         (IV)parno, REG_NODE_NUM(ret)));
10982                     RExC_open_parens[parno-1]= ret;
10983                 }
10984             }
10985             Set_Node_Length(ret, 1); /* MJD */
10986             Set_Node_Offset(ret, RExC_parse); /* MJD */
10987             is_open = 1;
10988         } else {
10989             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
10990             paren = ':';
10991             ret = NULL;
10992         }
10993     }
10994     else                        /* ! paren */
10995         ret = NULL;
10996
10997    parse_rest:
10998     /* Pick up the branches, linking them together. */
10999     parse_start = RExC_parse;   /* MJD */
11000     br = regbranch(pRExC_state, &flags, 1,depth+1);
11001
11002     /*     branch_len = (paren != 0); */
11003
11004     if (br == NULL) {
11005         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11006             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11007             return NULL;
11008         }
11009         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
11010     }
11011     if (*RExC_parse == '|') {
11012         if (!SIZE_ONLY && RExC_extralen) {
11013             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11014         }
11015         else {                  /* MJD */
11016             reginsert(pRExC_state, BRANCH, br, depth+1);
11017             Set_Node_Length(br, paren != 0);
11018             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11019         }
11020         have_branch = 1;
11021         if (SIZE_ONLY)
11022             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11023     }
11024     else if (paren == ':') {
11025         *flagp |= flags&SIMPLE;
11026     }
11027     if (is_open) {                              /* Starts with OPEN. */
11028         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11029     }
11030     else if (paren != '?')              /* Not Conditional */
11031         ret = br;
11032     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11033     lastbr = br;
11034     while (*RExC_parse == '|') {
11035         if (!SIZE_ONLY && RExC_extralen) {
11036             ender = reganode(pRExC_state, LONGJMP,0);
11037
11038             /* Append to the previous. */
11039             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11040         }
11041         if (SIZE_ONLY)
11042             RExC_extralen += 2;         /* Account for LONGJMP. */
11043         nextchar(pRExC_state);
11044         if (freeze_paren) {
11045             if (RExC_npar > after_freeze)
11046                 after_freeze = RExC_npar;
11047             RExC_npar = freeze_paren;
11048         }
11049         br = regbranch(pRExC_state, &flags, 0, depth+1);
11050
11051         if (br == NULL) {
11052             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11053                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11054                 return NULL;
11055             }
11056             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
11057         }
11058         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11059         lastbr = br;
11060         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11061     }
11062
11063     if (have_branch || paren != ':') {
11064         /* Make a closing node, and hook it on the end. */
11065         switch (paren) {
11066         case ':':
11067             ender = reg_node(pRExC_state, TAIL);
11068             break;
11069         case 1: case 2:
11070             ender = reganode(pRExC_state, CLOSE, parno);
11071             if (!SIZE_ONLY && RExC_seen & REG_RECURSE_SEEN) {
11072                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
11073                         "%*s%*s Setting close paren #%"IVdf" to %d\n",
11074                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11075                 RExC_close_parens[parno-1]= ender;
11076                 if (RExC_nestroot == parno)
11077                     RExC_nestroot = 0;
11078             }
11079             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11080             Set_Node_Length(ender,1); /* MJD */
11081             break;
11082         case '<':
11083         case ',':
11084         case '=':
11085         case '!':
11086             *flagp &= ~HASWIDTH;
11087             /* FALLTHROUGH */
11088         case '>':
11089             ender = reg_node(pRExC_state, SUCCEED);
11090             break;
11091         case 0:
11092             ender = reg_node(pRExC_state, END);
11093             if (!SIZE_ONLY) {
11094                 assert(!RExC_opend); /* there can only be one! */
11095                 RExC_opend = ender;
11096             }
11097             break;
11098         }
11099         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11100             DEBUG_PARSE_MSG("lsbr");
11101             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11102             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11103             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
11104                           SvPV_nolen_const(RExC_mysv1),
11105                           (IV)REG_NODE_NUM(lastbr),
11106                           SvPV_nolen_const(RExC_mysv2),
11107                           (IV)REG_NODE_NUM(ender),
11108                           (IV)(ender - lastbr)
11109             );
11110         });
11111         REGTAIL(pRExC_state, lastbr, ender);
11112
11113         if (have_branch && !SIZE_ONLY) {
11114             char is_nothing= 1;
11115             if (depth==1)
11116                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11117
11118             /* Hook the tails of the branches to the closing node. */
11119             for (br = ret; br; br = regnext(br)) {
11120                 const U8 op = PL_regkind[OP(br)];
11121                 if (op == BRANCH) {
11122                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11123                     if ( OP(NEXTOPER(br)) != NOTHING
11124                          || regnext(NEXTOPER(br)) != ender)
11125                         is_nothing= 0;
11126                 }
11127                 else if (op == BRANCHJ) {
11128                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11129                     /* for now we always disable this optimisation * /
11130                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11131                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11132                     */
11133                         is_nothing= 0;
11134                 }
11135             }
11136             if (is_nothing) {
11137                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11138                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11139                     DEBUG_PARSE_MSG("NADA");
11140                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11141                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11142                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
11143                                   SvPV_nolen_const(RExC_mysv1),
11144                                   (IV)REG_NODE_NUM(ret),
11145                                   SvPV_nolen_const(RExC_mysv2),
11146                                   (IV)REG_NODE_NUM(ender),
11147                                   (IV)(ender - ret)
11148                     );
11149                 });
11150                 OP(br)= NOTHING;
11151                 if (OP(ender) == TAIL) {
11152                     NEXT_OFF(br)= 0;
11153                     RExC_emit= br + 1;
11154                 } else {
11155                     regnode *opt;
11156                     for ( opt= br + 1; opt < ender ; opt++ )
11157                         OP(opt)= OPTIMIZED;
11158                     NEXT_OFF(br)= ender - br;
11159                 }
11160             }
11161         }
11162     }
11163
11164     {
11165         const char *p;
11166         static const char parens[] = "=!<,>";
11167
11168         if (paren && (p = strchr(parens, paren))) {
11169             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11170             int flag = (p - parens) > 1;
11171
11172             if (paren == '>')
11173                 node = SUSPEND, flag = 0;
11174             reginsert(pRExC_state, node,ret, depth+1);
11175             Set_Node_Cur_Length(ret, parse_start);
11176             Set_Node_Offset(ret, parse_start + 1);
11177             ret->flags = flag;
11178             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11179         }
11180     }
11181
11182     /* Check for proper termination. */
11183     if (paren) {
11184         /* restore original flags, but keep (?p) and, if we've changed from /d
11185          * rules to /u, keep the /u */
11186         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11187         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11188             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11189         }
11190         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11191             RExC_parse = oregcomp_parse;
11192             vFAIL("Unmatched (");
11193         }
11194         nextchar(pRExC_state);
11195     }
11196     else if (!paren && RExC_parse < RExC_end) {
11197         if (*RExC_parse == ')') {
11198             RExC_parse++;
11199             vFAIL("Unmatched )");
11200         }
11201         else
11202             FAIL("Junk on end of regexp");      /* "Can't happen". */
11203         NOT_REACHED; /* NOTREACHED */
11204     }
11205
11206     if (RExC_in_lookbehind) {
11207         RExC_in_lookbehind--;
11208     }
11209     if (after_freeze > RExC_npar)
11210         RExC_npar = after_freeze;
11211     return(ret);
11212 }
11213
11214 /*
11215  - regbranch - one alternative of an | operator
11216  *
11217  * Implements the concatenation operator.
11218  *
11219  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11220  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11221  */
11222 STATIC regnode *
11223 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11224 {
11225     regnode *ret;
11226     regnode *chain = NULL;
11227     regnode *latest;
11228     I32 flags = 0, c = 0;
11229     GET_RE_DEBUG_FLAGS_DECL;
11230
11231     PERL_ARGS_ASSERT_REGBRANCH;
11232
11233     DEBUG_PARSE("brnc");
11234
11235     if (first)
11236         ret = NULL;
11237     else {
11238         if (!SIZE_ONLY && RExC_extralen)
11239             ret = reganode(pRExC_state, BRANCHJ,0);
11240         else {
11241             ret = reg_node(pRExC_state, BRANCH);
11242             Set_Node_Length(ret, 1);
11243         }
11244     }
11245
11246     if (!first && SIZE_ONLY)
11247         RExC_extralen += 1;                     /* BRANCHJ */
11248
11249     *flagp = WORST;                     /* Tentatively. */
11250
11251     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11252                             FALSE /* Don't force to /x */ );
11253     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11254         flags &= ~TRYAGAIN;
11255         latest = regpiece(pRExC_state, &flags,depth+1);
11256         if (latest == NULL) {
11257             if (flags & TRYAGAIN)
11258                 continue;
11259             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11260                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11261                 return NULL;
11262             }
11263             FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags);
11264         }
11265         else if (ret == NULL)
11266             ret = latest;
11267         *flagp |= flags&(HASWIDTH|POSTPONED);
11268         if (chain == NULL)      /* First piece. */
11269             *flagp |= flags&SPSTART;
11270         else {
11271             /* FIXME adding one for every branch after the first is probably
11272              * excessive now we have TRIE support. (hv) */
11273             MARK_NAUGHTY(1);
11274             REGTAIL(pRExC_state, chain, latest);
11275         }
11276         chain = latest;
11277         c++;
11278     }
11279     if (chain == NULL) {        /* Loop ran zero times. */
11280         chain = reg_node(pRExC_state, NOTHING);
11281         if (ret == NULL)
11282             ret = chain;
11283     }
11284     if (c == 1) {
11285         *flagp |= flags&SIMPLE;
11286     }
11287
11288     return ret;
11289 }
11290
11291 /*
11292  - regpiece - something followed by possible [*+?]
11293  *
11294  * Note that the branching code sequences used for ? and the general cases
11295  * of * and + are somewhat optimized:  they use the same NOTHING node as
11296  * both the endmarker for their branch list and the body of the last branch.
11297  * It might seem that this node could be dispensed with entirely, but the
11298  * endmarker role is not redundant.
11299  *
11300  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11301  * TRYAGAIN.
11302  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11303  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11304  */
11305 STATIC regnode *
11306 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11307 {
11308     regnode *ret;
11309     char op;
11310     char *next;
11311     I32 flags;
11312     const char * const origparse = RExC_parse;
11313     I32 min;
11314     I32 max = REG_INFTY;
11315 #ifdef RE_TRACK_PATTERN_OFFSETS
11316     char *parse_start;
11317 #endif
11318     const char *maxpos = NULL;
11319     UV uv;
11320
11321     /* Save the original in case we change the emitted regop to a FAIL. */
11322     regnode * const orig_emit = RExC_emit;
11323
11324     GET_RE_DEBUG_FLAGS_DECL;
11325
11326     PERL_ARGS_ASSERT_REGPIECE;
11327
11328     DEBUG_PARSE("piec");
11329
11330     ret = regatom(pRExC_state, &flags,depth+1);
11331     if (ret == NULL) {
11332         if (flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8))
11333             *flagp |= flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8);
11334         else
11335             FAIL2("panic: regatom returned NULL, flags=%#"UVxf"", (UV) flags);
11336         return(NULL);
11337     }
11338
11339     op = *RExC_parse;
11340
11341     if (op == '{' && regcurly(RExC_parse)) {
11342         maxpos = NULL;
11343 #ifdef RE_TRACK_PATTERN_OFFSETS
11344         parse_start = RExC_parse; /* MJD */
11345 #endif
11346         next = RExC_parse + 1;
11347         while (isDIGIT(*next) || *next == ',') {
11348             if (*next == ',') {
11349                 if (maxpos)
11350                     break;
11351                 else
11352                     maxpos = next;
11353             }
11354             next++;
11355         }
11356         if (*next == '}') {             /* got one */
11357             const char* endptr;
11358             if (!maxpos)
11359                 maxpos = next;
11360             RExC_parse++;
11361             if (isDIGIT(*RExC_parse)) {
11362                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
11363                     vFAIL("Invalid quantifier in {,}");
11364                 if (uv >= REG_INFTY)
11365                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11366                 min = (I32)uv;
11367             } else {
11368                 min = 0;
11369             }
11370             if (*maxpos == ',')
11371                 maxpos++;
11372             else
11373                 maxpos = RExC_parse;
11374             if (isDIGIT(*maxpos)) {
11375                 if (!grok_atoUV(maxpos, &uv, &endptr))
11376                     vFAIL("Invalid quantifier in {,}");
11377                 if (uv >= REG_INFTY)
11378                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11379                 max = (I32)uv;
11380             } else {
11381                 max = REG_INFTY;                /* meaning "infinity" */
11382             }
11383             RExC_parse = next;
11384             nextchar(pRExC_state);
11385             if (max < min) {    /* If can't match, warn and optimize to fail
11386                                    unconditionally */
11387                 if (SIZE_ONLY) {
11388
11389                     /* We can't back off the size because we have to reserve
11390                      * enough space for all the things we are about to throw
11391                      * away, but we can shrink it by the amount we are about
11392                      * to re-use here */
11393                     RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
11394                 }
11395                 else {
11396                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
11397                     RExC_emit = orig_emit;
11398                 }
11399                 ret = reganode(pRExC_state, OPFAIL, 0);
11400                 return ret;
11401             }
11402             else if (min == max && *RExC_parse == '?')
11403             {
11404                 if (PASS2) {
11405                     ckWARN2reg(RExC_parse + 1,
11406                                "Useless use of greediness modifier '%c'",
11407                                *RExC_parse);
11408                 }
11409             }
11410
11411           do_curly:
11412             if ((flags&SIMPLE)) {
11413                 if (min == 0 && max == REG_INFTY) {
11414                     reginsert(pRExC_state, STAR, ret, depth+1);
11415                     ret->flags = 0;
11416                     MARK_NAUGHTY(4);
11417                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11418                     goto nest_check;
11419                 }
11420                 if (min == 1 && max == REG_INFTY) {
11421                     reginsert(pRExC_state, PLUS, ret, depth+1);
11422                     ret->flags = 0;
11423                     MARK_NAUGHTY(3);
11424                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11425                     goto nest_check;
11426                 }
11427                 MARK_NAUGHTY_EXP(2, 2);
11428                 reginsert(pRExC_state, CURLY, ret, depth+1);
11429                 Set_Node_Offset(ret, parse_start+1); /* MJD */
11430                 Set_Node_Cur_Length(ret, parse_start);
11431             }
11432             else {
11433                 regnode * const w = reg_node(pRExC_state, WHILEM);
11434
11435                 w->flags = 0;
11436                 REGTAIL(pRExC_state, ret, w);
11437                 if (!SIZE_ONLY && RExC_extralen) {
11438                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
11439                     reginsert(pRExC_state, NOTHING,ret, depth+1);
11440                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
11441                 }
11442                 reginsert(pRExC_state, CURLYX,ret, depth+1);
11443                                 /* MJD hk */
11444                 Set_Node_Offset(ret, parse_start+1);
11445                 Set_Node_Length(ret,
11446                                 op == '{' ? (RExC_parse - parse_start) : 1);
11447
11448                 if (!SIZE_ONLY && RExC_extralen)
11449                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
11450                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
11451                 if (SIZE_ONLY)
11452                     RExC_whilem_seen++, RExC_extralen += 3;
11453                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
11454             }
11455             ret->flags = 0;
11456
11457             if (min > 0)
11458                 *flagp = WORST;
11459             if (max > 0)
11460                 *flagp |= HASWIDTH;
11461             if (!SIZE_ONLY) {
11462                 ARG1_SET(ret, (U16)min);
11463                 ARG2_SET(ret, (U16)max);
11464             }
11465             if (max == REG_INFTY)
11466                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11467
11468             goto nest_check;
11469         }
11470     }
11471
11472     if (!ISMULT1(op)) {
11473         *flagp = flags;
11474         return(ret);
11475     }
11476
11477 #if 0                           /* Now runtime fix should be reliable. */
11478
11479     /* if this is reinstated, don't forget to put this back into perldiag:
11480
11481             =item Regexp *+ operand could be empty at {#} in regex m/%s/
11482
11483            (F) The part of the regexp subject to either the * or + quantifier
11484            could match an empty string. The {#} shows in the regular
11485            expression about where the problem was discovered.
11486
11487     */
11488
11489     if (!(flags&HASWIDTH) && op != '?')
11490       vFAIL("Regexp *+ operand could be empty");
11491 #endif
11492
11493 #ifdef RE_TRACK_PATTERN_OFFSETS
11494     parse_start = RExC_parse;
11495 #endif
11496     nextchar(pRExC_state);
11497
11498     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
11499
11500     if (op == '*') {
11501         min = 0;
11502         goto do_curly;
11503     }
11504     else if (op == '+') {
11505         min = 1;
11506         goto do_curly;
11507     }
11508     else if (op == '?') {
11509         min = 0; max = 1;
11510         goto do_curly;
11511     }
11512   nest_check:
11513     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
11514         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11515         ckWARN2reg(RExC_parse,
11516                    "%"UTF8f" matches null string many times",
11517                    UTF8fARG(UTF, (RExC_parse >= origparse
11518                                  ? RExC_parse - origparse
11519                                  : 0),
11520                    origparse));
11521         (void)ReREFCNT_inc(RExC_rx_sv);
11522     }
11523
11524     if (*RExC_parse == '?') {
11525         nextchar(pRExC_state);
11526         reginsert(pRExC_state, MINMOD, ret, depth+1);
11527         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11528     }
11529     else if (*RExC_parse == '+') {
11530         regnode *ender;
11531         nextchar(pRExC_state);
11532         ender = reg_node(pRExC_state, SUCCEED);
11533         REGTAIL(pRExC_state, ret, ender);
11534         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11535         ret->flags = 0;
11536         ender = reg_node(pRExC_state, TAIL);
11537         REGTAIL(pRExC_state, ret, ender);
11538     }
11539
11540     if (ISMULT2(RExC_parse)) {
11541         RExC_parse++;
11542         vFAIL("Nested quantifiers");
11543     }
11544
11545     return(ret);
11546 }
11547
11548 STATIC bool
11549 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11550                 regnode ** node_p,
11551                 UV * code_point_p,
11552                 int * cp_count,
11553                 I32 * flagp,
11554                 const bool strict,
11555                 const U32 depth
11556     )
11557 {
11558  /* This routine teases apart the various meanings of \N and returns
11559   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11560   * in the current context.
11561   *
11562   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11563   *
11564   * If <code_point_p> is not NULL, the context is expecting the result to be a
11565   * single code point.  If this \N instance turns out to a single code point,
11566   * the function returns TRUE and sets *code_point_p to that code point.
11567   *
11568   * If <node_p> is not NULL, the context is expecting the result to be one of
11569   * the things representable by a regnode.  If this \N instance turns out to be
11570   * one such, the function generates the regnode, returns TRUE and sets *node_p
11571   * to point to that regnode.
11572   *
11573   * If this instance of \N isn't legal in any context, this function will
11574   * generate a fatal error and not return.
11575   *
11576   * On input, RExC_parse should point to the first char following the \N at the
11577   * time of the call.  On successful return, RExC_parse will have been updated
11578   * to point to just after the sequence identified by this routine.  Also
11579   * *flagp has been updated as needed.
11580   *
11581   * When there is some problem with the current context and this \N instance,
11582   * the function returns FALSE, without advancing RExC_parse, nor setting
11583   * *node_p, nor *code_point_p, nor *flagp.
11584   *
11585   * If <cp_count> is not NULL, the caller wants to know the length (in code
11586   * points) that this \N sequence matches.  This is set even if the function
11587   * returns FALSE, as detailed below.
11588   *
11589   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11590   *
11591   * Probably the most common case is for the \N to specify a single code point.
11592   * *cp_count will be set to 1, and *code_point_p will be set to that code
11593   * point.
11594   *
11595   * Another possibility is for the input to be an empty \N{}, which for
11596   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11597   * will be set to a generated NOTHING node.
11598   *
11599   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11600   * set to 0. *node_p will be set to a generated REG_ANY node.
11601   *
11602   * The fourth possibility is that \N resolves to a sequence of more than one
11603   * code points.  *cp_count will be set to the number of code points in the
11604   * sequence. *node_p * will be set to a generated node returned by this
11605   * function calling S_reg().
11606   *
11607   * The final possibility is that it is premature to be calling this function;
11608   * that pass1 needs to be restarted.  This can happen when this changes from
11609   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
11610   * latter occurs only when the fourth possibility would otherwise be in
11611   * effect, and is because one of those code points requires the pattern to be
11612   * recompiled as UTF-8.  The function returns FALSE, and sets the
11613   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
11614   * happens, the caller needs to desist from continuing parsing, and return
11615   * this information to its caller.  This is not set for when there is only one
11616   * code point, as this can be called as part of an ANYOF node, and they can
11617   * store above-Latin1 code points without the pattern having to be in UTF-8.
11618   *
11619   * For non-single-quoted regexes, the tokenizer has resolved character and
11620   * sequence names inside \N{...} into their Unicode values, normalizing the
11621   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11622   * hex-represented code points in the sequence.  This is done there because
11623   * the names can vary based on what charnames pragma is in scope at the time,
11624   * so we need a way to take a snapshot of what they resolve to at the time of
11625   * the original parse. [perl #56444].
11626   *
11627   * That parsing is skipped for single-quoted regexes, so we may here get
11628   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11629   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11630   * is legal and handled here.  The code point is Unicode, and has to be
11631   * translated into the native character set for non-ASCII platforms.
11632   */
11633
11634     char * endbrace;    /* points to '}' following the name */
11635     char *endchar;      /* Points to '.' or '}' ending cur char in the input
11636                            stream */
11637     char* p = RExC_parse; /* Temporary */
11638
11639     GET_RE_DEBUG_FLAGS_DECL;
11640
11641     PERL_ARGS_ASSERT_GROK_BSLASH_N;
11642
11643     GET_RE_DEBUG_FLAGS;
11644
11645     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
11646     assert(! (node_p && cp_count));               /* At most 1 should be set */
11647
11648     if (cp_count) {     /* Initialize return for the most common case */
11649         *cp_count = 1;
11650     }
11651
11652     /* The [^\n] meaning of \N ignores spaces and comments under the /x
11653      * modifier.  The other meanings do not, so use a temporary until we find
11654      * out which we are being called with */
11655     skip_to_be_ignored_text(pRExC_state, &p,
11656                             FALSE /* Don't force to /x */ );
11657
11658     /* Disambiguate between \N meaning a named character versus \N meaning
11659      * [^\n].  The latter is assumed when the {...} following the \N is a legal
11660      * quantifier, or there is no '{' at all */
11661     if (*p != '{' || regcurly(p)) {
11662         RExC_parse = p;
11663         if (cp_count) {
11664             *cp_count = -1;
11665         }
11666
11667         if (! node_p) {
11668             return FALSE;
11669         }
11670
11671         *node_p = reg_node(pRExC_state, REG_ANY);
11672         *flagp |= HASWIDTH|SIMPLE;
11673         MARK_NAUGHTY(1);
11674         Set_Node_Length(*node_p, 1); /* MJD */
11675         return TRUE;
11676     }
11677
11678     /* Here, we have decided it should be a named character or sequence */
11679
11680     /* The test above made sure that the next real character is a '{', but
11681      * under the /x modifier, it could be separated by space (or a comment and
11682      * \n) and this is not allowed (for consistency with \x{...} and the
11683      * tokenizer handling of \N{NAME}). */
11684     if (*RExC_parse != '{') {
11685         vFAIL("Missing braces on \\N{}");
11686     }
11687
11688     RExC_parse++;       /* Skip past the '{' */
11689
11690     if (! (endbrace = strchr(RExC_parse, '}'))  /* no trailing brace */
11691         || ! (endbrace == RExC_parse            /* nothing between the {} */
11692               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
11693                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
11694                                                        error msg) */
11695     {
11696         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
11697         vFAIL("\\N{NAME} must be resolved by the lexer");
11698     }
11699
11700     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
11701                                         semantics */
11702
11703     if (endbrace == RExC_parse) {   /* empty: \N{} */
11704         if (strict) {
11705             RExC_parse++;   /* Position after the "}" */
11706             vFAIL("Zero length \\N{}");
11707         }
11708         if (cp_count) {
11709             *cp_count = 0;
11710         }
11711         nextchar(pRExC_state);
11712         if (! node_p) {
11713             return FALSE;
11714         }
11715
11716         *node_p = reg_node(pRExC_state,NOTHING);
11717         return TRUE;
11718     }
11719
11720     RExC_parse += 2;    /* Skip past the 'U+' */
11721
11722     /* Because toke.c has generated a special construct for us guaranteed not
11723      * to have NULs, we can use a str function */
11724     endchar = RExC_parse + strcspn(RExC_parse, ".}");
11725
11726     /* Code points are separated by dots.  If none, there is only one code
11727      * point, and is terminated by the brace */
11728
11729     if (endchar >= endbrace) {
11730         STRLEN length_of_hex;
11731         I32 grok_hex_flags;
11732
11733         /* Here, exactly one code point.  If that isn't what is wanted, fail */
11734         if (! code_point_p) {
11735             RExC_parse = p;
11736             return FALSE;
11737         }
11738
11739         /* Convert code point from hex */
11740         length_of_hex = (STRLEN)(endchar - RExC_parse);
11741         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
11742                            | PERL_SCAN_DISALLOW_PREFIX
11743
11744                              /* No errors in the first pass (See [perl
11745                               * #122671].)  We let the code below find the
11746                               * errors when there are multiple chars. */
11747                            | ((SIZE_ONLY)
11748                               ? PERL_SCAN_SILENT_ILLDIGIT
11749                               : 0);
11750
11751         /* This routine is the one place where both single- and double-quotish
11752          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
11753          * must be converted to native. */
11754         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
11755                                          &length_of_hex,
11756                                          &grok_hex_flags,
11757                                          NULL));
11758
11759         /* The tokenizer should have guaranteed validity, but it's possible to
11760          * bypass it by using single quoting, so check.  Don't do the check
11761          * here when there are multiple chars; we do it below anyway. */
11762         if (length_of_hex == 0
11763             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
11764         {
11765             RExC_parse += length_of_hex;        /* Includes all the valid */
11766             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
11767                             ? UTF8SKIP(RExC_parse)
11768                             : 1;
11769             /* Guard against malformed utf8 */
11770             if (RExC_parse >= endchar) {
11771                 RExC_parse = endchar;
11772             }
11773             vFAIL("Invalid hexadecimal number in \\N{U+...}");
11774         }
11775
11776         RExC_parse = endbrace + 1;
11777         return TRUE;
11778     }
11779     else {  /* Is a multiple character sequence */
11780         SV * substitute_parse;
11781         STRLEN len;
11782         char *orig_end = RExC_end;
11783         char *save_start = RExC_start;
11784         I32 flags;
11785
11786         /* Count the code points, if desired, in the sequence */
11787         if (cp_count) {
11788             *cp_count = 0;
11789             while (RExC_parse < endbrace) {
11790                 /* Point to the beginning of the next character in the sequence. */
11791                 RExC_parse = endchar + 1;
11792                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
11793                 (*cp_count)++;
11794             }
11795         }
11796
11797         /* Fail if caller doesn't want to handle a multi-code-point sequence.
11798          * But don't backup up the pointer if the caller want to know how many
11799          * code points there are (they can then handle things) */
11800         if (! node_p) {
11801             if (! cp_count) {
11802                 RExC_parse = p;
11803             }
11804             return FALSE;
11805         }
11806
11807         /* What is done here is to convert this to a sub-pattern of the form
11808          * \x{char1}\x{char2}...  and then call reg recursively to parse it
11809          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
11810          * while not having to worry about special handling that some code
11811          * points may have. */
11812
11813         substitute_parse = newSVpvs("?:");
11814
11815         while (RExC_parse < endbrace) {
11816
11817             /* Convert to notation the rest of the code understands */
11818             sv_catpv(substitute_parse, "\\x{");
11819             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
11820             sv_catpv(substitute_parse, "}");
11821
11822             /* Point to the beginning of the next character in the sequence. */
11823             RExC_parse = endchar + 1;
11824             endchar = RExC_parse + strcspn(RExC_parse, ".}");
11825
11826         }
11827         sv_catpv(substitute_parse, ")");
11828
11829         RExC_parse = RExC_start = RExC_adjusted_start = SvPV(substitute_parse,
11830                                                              len);
11831
11832         /* Don't allow empty number */
11833         if (len < (STRLEN) 8) {
11834             RExC_parse = endbrace;
11835             vFAIL("Invalid hexadecimal number in \\N{U+...}");
11836         }
11837         RExC_end = RExC_parse + len;
11838
11839         /* The values are Unicode, and therefore not subject to recoding, but
11840          * have to be converted to native on a non-Unicode (meaning non-ASCII)
11841          * platform. */
11842         RExC_override_recoding = 1;
11843 #ifdef EBCDIC
11844         RExC_recode_x_to_native = 1;
11845 #endif
11846
11847         if (node_p) {
11848             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
11849                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
11850                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11851                     return FALSE;
11852                 }
11853                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
11854                     (UV) flags);
11855             }
11856             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
11857         }
11858
11859         /* Restore the saved values */
11860         RExC_start = RExC_adjusted_start = save_start;
11861         RExC_parse = endbrace;
11862         RExC_end = orig_end;
11863         RExC_override_recoding = 0;
11864 #ifdef EBCDIC
11865         RExC_recode_x_to_native = 0;
11866 #endif
11867
11868         SvREFCNT_dec_NN(substitute_parse);
11869         nextchar(pRExC_state);
11870
11871         return TRUE;
11872     }
11873 }
11874
11875
11876 /*
11877  * reg_recode
11878  *
11879  * It returns the code point in utf8 for the value in *encp.
11880  *    value: a code value in the source encoding
11881  *    encp:  a pointer to an Encode object
11882  *
11883  * If the result from Encode is not a single character,
11884  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
11885  */
11886 STATIC UV
11887 S_reg_recode(pTHX_ const U8 value, SV **encp)
11888 {
11889     STRLEN numlen = 1;
11890     SV * const sv = newSVpvn_flags((const char *) &value, numlen, SVs_TEMP);
11891     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
11892     const STRLEN newlen = SvCUR(sv);
11893     UV uv = UNICODE_REPLACEMENT;
11894
11895     PERL_ARGS_ASSERT_REG_RECODE;
11896
11897     if (newlen)
11898         uv = SvUTF8(sv)
11899              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
11900              : *(U8*)s;
11901
11902     if (!newlen || numlen != newlen) {
11903         uv = UNICODE_REPLACEMENT;
11904         *encp = NULL;
11905     }
11906     return uv;
11907 }
11908
11909 PERL_STATIC_INLINE U8
11910 S_compute_EXACTish(RExC_state_t *pRExC_state)
11911 {
11912     U8 op;
11913
11914     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
11915
11916     if (! FOLD) {
11917         return (LOC)
11918                 ? EXACTL
11919                 : EXACT;
11920     }
11921
11922     op = get_regex_charset(RExC_flags);
11923     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
11924         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
11925                  been, so there is no hole */
11926     }
11927
11928     return op + EXACTF;
11929 }
11930
11931 PERL_STATIC_INLINE void
11932 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
11933                          regnode *node, I32* flagp, STRLEN len, UV code_point,
11934                          bool downgradable)
11935 {
11936     /* This knows the details about sizing an EXACTish node, setting flags for
11937      * it (by setting <*flagp>, and potentially populating it with a single
11938      * character.
11939      *
11940      * If <len> (the length in bytes) is non-zero, this function assumes that
11941      * the node has already been populated, and just does the sizing.  In this
11942      * case <code_point> should be the final code point that has already been
11943      * placed into the node.  This value will be ignored except that under some
11944      * circumstances <*flagp> is set based on it.
11945      *
11946      * If <len> is zero, the function assumes that the node is to contain only
11947      * the single character given by <code_point> and calculates what <len>
11948      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
11949      * additionally will populate the node's STRING with <code_point> or its
11950      * fold if folding.
11951      *
11952      * In both cases <*flagp> is appropriately set
11953      *
11954      * It knows that under FOLD, the Latin Sharp S and UTF characters above
11955      * 255, must be folded (the former only when the rules indicate it can
11956      * match 'ss')
11957      *
11958      * When it does the populating, it looks at the flag 'downgradable'.  If
11959      * true with a node that folds, it checks if the single code point
11960      * participates in a fold, and if not downgrades the node to an EXACT.
11961      * This helps the optimizer */
11962
11963     bool len_passed_in = cBOOL(len != 0);
11964     U8 character[UTF8_MAXBYTES_CASE+1];
11965
11966     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
11967
11968     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
11969      * sizing difference, and is extra work that is thrown away */
11970     if (downgradable && ! PASS2) {
11971         downgradable = FALSE;
11972     }
11973
11974     if (! len_passed_in) {
11975         if (UTF) {
11976             if (UVCHR_IS_INVARIANT(code_point)) {
11977                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
11978                     *character = (U8) code_point;
11979                 }
11980                 else { /* Here is /i and not /l. (toFOLD() is defined on just
11981                           ASCII, which isn't the same thing as INVARIANT on
11982                           EBCDIC, but it works there, as the extra invariants
11983                           fold to themselves) */
11984                     *character = toFOLD((U8) code_point);
11985
11986                     /* We can downgrade to an EXACT node if this character
11987                      * isn't a folding one.  Note that this assumes that
11988                      * nothing above Latin1 folds to some other invariant than
11989                      * one of these alphabetics; otherwise we would also have
11990                      * to check:
11991                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
11992                      *      || ASCII_FOLD_RESTRICTED))
11993                      */
11994                     if (downgradable && PL_fold[code_point] == code_point) {
11995                         OP(node) = EXACT;
11996                     }
11997                 }
11998                 len = 1;
11999             }
12000             else if (FOLD && (! LOC
12001                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12002             {   /* Folding, and ok to do so now */
12003                 UV folded = _to_uni_fold_flags(
12004                                    code_point,
12005                                    character,
12006                                    &len,
12007                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12008                                                       ? FOLD_FLAGS_NOMIX_ASCII
12009                                                       : 0));
12010                 if (downgradable
12011                     && folded == code_point /* This quickly rules out many
12012                                                cases, avoiding the
12013                                                _invlist_contains_cp() overhead
12014                                                for those.  */
12015                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12016                 {
12017                     OP(node) = (LOC)
12018                                ? EXACTL
12019                                : EXACT;
12020                 }
12021             }
12022             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12023
12024                 /* Not folding this cp, and can output it directly */
12025                 *character = UTF8_TWO_BYTE_HI(code_point);
12026                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12027                 len = 2;
12028             }
12029             else {
12030                 uvchr_to_utf8( character, code_point);
12031                 len = UTF8SKIP(character);
12032             }
12033         } /* Else pattern isn't UTF8.  */
12034         else if (! FOLD) {
12035             *character = (U8) code_point;
12036             len = 1;
12037         } /* Else is folded non-UTF8 */
12038 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12039    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12040                                       || UNICODE_DOT_DOT_VERSION > 0)
12041         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12042 #else
12043         else if (1) {
12044 #endif
12045             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12046              * comments at join_exact()); */
12047             *character = (U8) code_point;
12048             len = 1;
12049
12050             /* Can turn into an EXACT node if we know the fold at compile time,
12051              * and it folds to itself and doesn't particpate in other folds */
12052             if (downgradable
12053                 && ! LOC
12054                 && PL_fold_latin1[code_point] == code_point
12055                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12056                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12057             {
12058                 OP(node) = EXACT;
12059             }
12060         } /* else is Sharp s.  May need to fold it */
12061         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12062             *character = 's';
12063             *(character + 1) = 's';
12064             len = 2;
12065         }
12066         else {
12067             *character = LATIN_SMALL_LETTER_SHARP_S;
12068             len = 1;
12069         }
12070     }
12071
12072     if (SIZE_ONLY) {
12073         RExC_size += STR_SZ(len);
12074     }
12075     else {
12076         RExC_emit += STR_SZ(len);
12077         STR_LEN(node) = len;
12078         if (! len_passed_in) {
12079             Copy((char *) character, STRING(node), len, char);
12080         }
12081     }
12082
12083     *flagp |= HASWIDTH;
12084
12085     /* A single character node is SIMPLE, except for the special-cased SHARP S
12086      * under /di. */
12087     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12088 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12089    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12090                                       || UNICODE_DOT_DOT_VERSION > 0)
12091         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12092             || ! FOLD || ! DEPENDS_SEMANTICS)
12093 #endif
12094     ) {
12095         *flagp |= SIMPLE;
12096     }
12097
12098     /* The OP may not be well defined in PASS1 */
12099     if (PASS2 && OP(node) == EXACTFL) {
12100         RExC_contains_locale = 1;
12101     }
12102 }
12103
12104
12105 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12106  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12107
12108 static I32
12109 S_backref_value(char *p)
12110 {
12111     const char* endptr;
12112     UV val;
12113     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12114         return (I32)val;
12115     return I32_MAX;
12116 }
12117
12118
12119 /*
12120  - regatom - the lowest level
12121
12122    Try to identify anything special at the start of the pattern. If there
12123    is, then handle it as required. This may involve generating a single regop,
12124    such as for an assertion; or it may involve recursing, such as to
12125    handle a () structure.
12126
12127    If the string doesn't start with something special then we gobble up
12128    as much literal text as we can.
12129
12130    Once we have been able to handle whatever type of thing started the
12131    sequence, we return.
12132
12133    Note: we have to be careful with escapes, as they can be both literal
12134    and special, and in the case of \10 and friends, context determines which.
12135
12136    A summary of the code structure is:
12137
12138    switch (first_byte) {
12139         cases for each special:
12140             handle this special;
12141             break;
12142         case '\\':
12143             switch (2nd byte) {
12144                 cases for each unambiguous special:
12145                     handle this special;
12146                     break;
12147                 cases for each ambigous special/literal:
12148                     disambiguate;
12149                     if (special)  handle here
12150                     else goto defchar;
12151                 default: // unambiguously literal:
12152                     goto defchar;
12153             }
12154         default:  // is a literal char
12155             // FALL THROUGH
12156         defchar:
12157             create EXACTish node for literal;
12158             while (more input and node isn't full) {
12159                 switch (input_byte) {
12160                    cases for each special;
12161                        make sure parse pointer is set so that the next call to
12162                            regatom will see this special first
12163                        goto loopdone; // EXACTish node terminated by prev. char
12164                    default:
12165                        append char to EXACTISH node;
12166                 }
12167                 get next input byte;
12168             }
12169         loopdone:
12170    }
12171    return the generated node;
12172
12173    Specifically there are two separate switches for handling
12174    escape sequences, with the one for handling literal escapes requiring
12175    a dummy entry for all of the special escapes that are actually handled
12176    by the other.
12177
12178    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12179    TRYAGAIN.
12180    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12181    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12182    Otherwise does not return NULL.
12183 */
12184
12185 STATIC regnode *
12186 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12187 {
12188     regnode *ret = NULL;
12189     I32 flags = 0;
12190     char *parse_start;
12191     U8 op;
12192     int invert = 0;
12193     U8 arg;
12194
12195     GET_RE_DEBUG_FLAGS_DECL;
12196
12197     *flagp = WORST;             /* Tentatively. */
12198
12199     DEBUG_PARSE("atom");
12200
12201     PERL_ARGS_ASSERT_REGATOM;
12202
12203   tryagain:
12204     parse_start = RExC_parse;
12205     assert(RExC_parse < RExC_end);
12206     switch ((U8)*RExC_parse) {
12207     case '^':
12208         RExC_seen_zerolen++;
12209         nextchar(pRExC_state);
12210         if (RExC_flags & RXf_PMf_MULTILINE)
12211             ret = reg_node(pRExC_state, MBOL);
12212         else
12213             ret = reg_node(pRExC_state, SBOL);
12214         Set_Node_Length(ret, 1); /* MJD */
12215         break;
12216     case '$':
12217         nextchar(pRExC_state);
12218         if (*RExC_parse)
12219             RExC_seen_zerolen++;
12220         if (RExC_flags & RXf_PMf_MULTILINE)
12221             ret = reg_node(pRExC_state, MEOL);
12222         else
12223             ret = reg_node(pRExC_state, SEOL);
12224         Set_Node_Length(ret, 1); /* MJD */
12225         break;
12226     case '.':
12227         nextchar(pRExC_state);
12228         if (RExC_flags & RXf_PMf_SINGLELINE)
12229             ret = reg_node(pRExC_state, SANY);
12230         else
12231             ret = reg_node(pRExC_state, REG_ANY);
12232         *flagp |= HASWIDTH|SIMPLE;
12233         MARK_NAUGHTY(1);
12234         Set_Node_Length(ret, 1); /* MJD */
12235         break;
12236     case '[':
12237     {
12238         char * const oregcomp_parse = ++RExC_parse;
12239         ret = regclass(pRExC_state, flagp,depth+1,
12240                        FALSE, /* means parse the whole char class */
12241                        TRUE, /* allow multi-char folds */
12242                        FALSE, /* don't silence non-portable warnings. */
12243                        (bool) RExC_strict,
12244                        TRUE, /* Allow an optimized regnode result */
12245                        NULL,
12246                        NULL);
12247         if (ret == NULL) {
12248             if (*flagp & (RESTART_PASS1|NEED_UTF8))
12249                 return NULL;
12250             FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
12251                   (UV) *flagp);
12252         }
12253         if (*RExC_parse != ']') {
12254             RExC_parse = oregcomp_parse;
12255             vFAIL("Unmatched [");
12256         }
12257         nextchar(pRExC_state);
12258         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12259         break;
12260     }
12261     case '(':
12262         nextchar(pRExC_state);
12263         ret = reg(pRExC_state, 2, &flags,depth+1);
12264         if (ret == NULL) {
12265                 if (flags & TRYAGAIN) {
12266                     if (RExC_parse >= RExC_end) {
12267                          /* Make parent create an empty node if needed. */
12268                         *flagp |= TRYAGAIN;
12269                         return(NULL);
12270                     }
12271                     goto tryagain;
12272                 }
12273                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12274                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12275                     return NULL;
12276                 }
12277                 FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"",
12278                                                                  (UV) flags);
12279         }
12280         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12281         break;
12282     case '|':
12283     case ')':
12284         if (flags & TRYAGAIN) {
12285             *flagp |= TRYAGAIN;
12286             return NULL;
12287         }
12288         vFAIL("Internal urp");
12289                                 /* Supposed to be caught earlier. */
12290         break;
12291     case '?':
12292     case '+':
12293     case '*':
12294         RExC_parse++;
12295         vFAIL("Quantifier follows nothing");
12296         break;
12297     case '\\':
12298         /* Special Escapes
12299
12300            This switch handles escape sequences that resolve to some kind
12301            of special regop and not to literal text. Escape sequnces that
12302            resolve to literal text are handled below in the switch marked
12303            "Literal Escapes".
12304
12305            Every entry in this switch *must* have a corresponding entry
12306            in the literal escape switch. However, the opposite is not
12307            required, as the default for this switch is to jump to the
12308            literal text handling code.
12309         */
12310         RExC_parse++;
12311         switch ((U8)*RExC_parse) {
12312         /* Special Escapes */
12313         case 'A':
12314             RExC_seen_zerolen++;
12315             ret = reg_node(pRExC_state, SBOL);
12316             /* SBOL is shared with /^/ so we set the flags so we can tell
12317              * /\A/ from /^/ in split. We check ret because first pass we
12318              * have no regop struct to set the flags on. */
12319             if (PASS2)
12320                 ret->flags = 1;
12321             *flagp |= SIMPLE;
12322             goto finish_meta_pat;
12323         case 'G':
12324             ret = reg_node(pRExC_state, GPOS);
12325             RExC_seen |= REG_GPOS_SEEN;
12326             *flagp |= SIMPLE;
12327             goto finish_meta_pat;
12328         case 'K':
12329             RExC_seen_zerolen++;
12330             ret = reg_node(pRExC_state, KEEPS);
12331             *flagp |= SIMPLE;
12332             /* XXX:dmq : disabling in-place substitution seems to
12333              * be necessary here to avoid cases of memory corruption, as
12334              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
12335              */
12336             RExC_seen |= REG_LOOKBEHIND_SEEN;
12337             goto finish_meta_pat;
12338         case 'Z':
12339             ret = reg_node(pRExC_state, SEOL);
12340             *flagp |= SIMPLE;
12341             RExC_seen_zerolen++;                /* Do not optimize RE away */
12342             goto finish_meta_pat;
12343         case 'z':
12344             ret = reg_node(pRExC_state, EOS);
12345             *flagp |= SIMPLE;
12346             RExC_seen_zerolen++;                /* Do not optimize RE away */
12347             goto finish_meta_pat;
12348         case 'C':
12349             vFAIL("\\C no longer supported");
12350         case 'X':
12351             ret = reg_node(pRExC_state, CLUMP);
12352             *flagp |= HASWIDTH;
12353             goto finish_meta_pat;
12354
12355         case 'W':
12356             invert = 1;
12357             /* FALLTHROUGH */
12358         case 'w':
12359             arg = ANYOF_WORDCHAR;
12360             goto join_posix;
12361
12362         case 'B':
12363             invert = 1;
12364             /* FALLTHROUGH */
12365         case 'b':
12366           {
12367             regex_charset charset = get_regex_charset(RExC_flags);
12368
12369             RExC_seen_zerolen++;
12370             RExC_seen |= REG_LOOKBEHIND_SEEN;
12371             op = BOUND + charset;
12372
12373             if (op == BOUNDL) {
12374                 RExC_contains_locale = 1;
12375             }
12376
12377             ret = reg_node(pRExC_state, op);
12378             *flagp |= SIMPLE;
12379             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
12380                 FLAGS(ret) = TRADITIONAL_BOUND;
12381                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
12382                     OP(ret) = BOUNDA;
12383                 }
12384             }
12385             else {
12386                 STRLEN length;
12387                 char name = *RExC_parse;
12388                 char * endbrace;
12389                 RExC_parse += 2;
12390                 endbrace = strchr(RExC_parse, '}');
12391
12392                 if (! endbrace) {
12393                     vFAIL2("Missing right brace on \\%c{}", name);
12394                 }
12395                 /* XXX Need to decide whether to take spaces or not.  Should be
12396                  * consistent with \p{}, but that currently is SPACE, which
12397                  * means vertical too, which seems wrong
12398                  * while (isBLANK(*RExC_parse)) {
12399                     RExC_parse++;
12400                 }*/
12401                 if (endbrace == RExC_parse) {
12402                     RExC_parse++;  /* After the '}' */
12403                     vFAIL2("Empty \\%c{}", name);
12404                 }
12405                 length = endbrace - RExC_parse;
12406                 /*while (isBLANK(*(RExC_parse + length - 1))) {
12407                     length--;
12408                 }*/
12409                 switch (*RExC_parse) {
12410                     case 'g':
12411                         if (length != 1
12412                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
12413                         {
12414                             goto bad_bound_type;
12415                         }
12416                         FLAGS(ret) = GCB_BOUND;
12417                         break;
12418                     case 'l':
12419                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12420                             goto bad_bound_type;
12421                         }
12422                         FLAGS(ret) = LB_BOUND;
12423                         break;
12424                     case 's':
12425                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12426                             goto bad_bound_type;
12427                         }
12428                         FLAGS(ret) = SB_BOUND;
12429                         break;
12430                     case 'w':
12431                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12432                             goto bad_bound_type;
12433                         }
12434                         FLAGS(ret) = WB_BOUND;
12435                         break;
12436                     default:
12437                       bad_bound_type:
12438                         RExC_parse = endbrace;
12439                         vFAIL2utf8f(
12440                             "'%"UTF8f"' is an unknown bound type",
12441                             UTF8fARG(UTF, length, endbrace - length));
12442                         NOT_REACHED; /*NOTREACHED*/
12443                 }
12444                 RExC_parse = endbrace;
12445                 REQUIRE_UNI_RULES(flagp, NULL);
12446
12447                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
12448                     OP(ret) = BOUNDU;
12449                     length += 4;
12450
12451                     /* Don't have to worry about UTF-8, in this message because
12452                      * to get here the contents of the \b must be ASCII */
12453                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
12454                               "Using /u for '%.*s' instead of /%s",
12455                               (unsigned) length,
12456                               endbrace - length + 1,
12457                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
12458                               ? ASCII_RESTRICT_PAT_MODS
12459                               : ASCII_MORE_RESTRICT_PAT_MODS);
12460                 }
12461             }
12462
12463             if (PASS2 && invert) {
12464                 OP(ret) += NBOUND - BOUND;
12465             }
12466             goto finish_meta_pat;
12467           }
12468
12469         case 'D':
12470             invert = 1;
12471             /* FALLTHROUGH */
12472         case 'd':
12473             arg = ANYOF_DIGIT;
12474             if (! DEPENDS_SEMANTICS) {
12475                 goto join_posix;
12476             }
12477
12478             /* \d doesn't have any matches in the upper Latin1 range, hence /d
12479              * is equivalent to /u.  Changing to /u saves some branches at
12480              * runtime */
12481             op = POSIXU;
12482             goto join_posix_op_known;
12483
12484         case 'R':
12485             ret = reg_node(pRExC_state, LNBREAK);
12486             *flagp |= HASWIDTH|SIMPLE;
12487             goto finish_meta_pat;
12488
12489         case 'H':
12490             invert = 1;
12491             /* FALLTHROUGH */
12492         case 'h':
12493             arg = ANYOF_BLANK;
12494             op = POSIXU;
12495             goto join_posix_op_known;
12496
12497         case 'V':
12498             invert = 1;
12499             /* FALLTHROUGH */
12500         case 'v':
12501             arg = ANYOF_VERTWS;
12502             op = POSIXU;
12503             goto join_posix_op_known;
12504
12505         case 'S':
12506             invert = 1;
12507             /* FALLTHROUGH */
12508         case 's':
12509             arg = ANYOF_SPACE;
12510
12511           join_posix:
12512
12513             op = POSIXD + get_regex_charset(RExC_flags);
12514             if (op > POSIXA) {  /* /aa is same as /a */
12515                 op = POSIXA;
12516             }
12517             else if (op == POSIXL) {
12518                 RExC_contains_locale = 1;
12519             }
12520
12521           join_posix_op_known:
12522
12523             if (invert) {
12524                 op += NPOSIXD - POSIXD;
12525             }
12526
12527             ret = reg_node(pRExC_state, op);
12528             if (! SIZE_ONLY) {
12529                 FLAGS(ret) = namedclass_to_classnum(arg);
12530             }
12531
12532             *flagp |= HASWIDTH|SIMPLE;
12533             /* FALLTHROUGH */
12534
12535           finish_meta_pat:
12536             nextchar(pRExC_state);
12537             Set_Node_Length(ret, 2); /* MJD */
12538             break;
12539         case 'p':
12540         case 'P':
12541             RExC_parse--;
12542
12543             ret = regclass(pRExC_state, flagp,depth+1,
12544                            TRUE, /* means just parse this element */
12545                            FALSE, /* don't allow multi-char folds */
12546                            FALSE, /* don't silence non-portable warnings.  It
12547                                      would be a bug if these returned
12548                                      non-portables */
12549                            (bool) RExC_strict,
12550                            TRUE, /* Allow an optimized regnode result */
12551                            NULL,
12552                            NULL);
12553             if (*flagp & RESTART_PASS1)
12554                 return NULL;
12555             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
12556              * multi-char folds are allowed.  */
12557             if (!ret)
12558                 FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
12559                       (UV) *flagp);
12560
12561             RExC_parse--;
12562
12563             Set_Node_Offset(ret, parse_start);
12564             Set_Node_Cur_Length(ret, parse_start - 2);
12565             nextchar(pRExC_state);
12566             break;
12567         case 'N':
12568             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12569              * \N{...} evaluates to a sequence of more than one code points).
12570              * The function call below returns a regnode, which is our result.
12571              * The parameters cause it to fail if the \N{} evaluates to a
12572              * single code point; we handle those like any other literal.  The
12573              * reason that the multicharacter case is handled here and not as
12574              * part of the EXACtish code is because of quantifiers.  In
12575              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12576              * this way makes that Just Happen. dmq.
12577              * join_exact() will join this up with adjacent EXACTish nodes
12578              * later on, if appropriate. */
12579             ++RExC_parse;
12580             if (grok_bslash_N(pRExC_state,
12581                               &ret,     /* Want a regnode returned */
12582                               NULL,     /* Fail if evaluates to a single code
12583                                            point */
12584                               NULL,     /* Don't need a count of how many code
12585                                            points */
12586                               flagp,
12587                               RExC_strict,
12588                               depth)
12589             ) {
12590                 break;
12591             }
12592
12593             if (*flagp & RESTART_PASS1)
12594                 return NULL;
12595
12596             /* Here, evaluates to a single code point.  Go get that */
12597             RExC_parse = parse_start;
12598             goto defchar;
12599
12600         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12601       parse_named_seq:
12602         {
12603             char ch;
12604             if (   RExC_parse >= RExC_end - 1
12605                 || ((   ch = RExC_parse[1]) != '<'
12606                                       && ch != '\''
12607                                       && ch != '{'))
12608             {
12609                 RExC_parse++;
12610                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12611                 vFAIL2("Sequence %.2s... not terminated",parse_start);
12612             } else {
12613                 RExC_parse += 2;
12614                 ret = handle_named_backref(pRExC_state,
12615                                            flagp,
12616                                            parse_start,
12617                                            (ch == '<')
12618                                            ? '>'
12619                                            : (ch == '{')
12620                                              ? '}'
12621                                              : '\'');
12622             }
12623             break;
12624         }
12625         case 'g':
12626         case '1': case '2': case '3': case '4':
12627         case '5': case '6': case '7': case '8': case '9':
12628             {
12629                 I32 num;
12630                 bool hasbrace = 0;
12631
12632                 if (*RExC_parse == 'g') {
12633                     bool isrel = 0;
12634
12635                     RExC_parse++;
12636                     if (*RExC_parse == '{') {
12637                         RExC_parse++;
12638                         hasbrace = 1;
12639                     }
12640                     if (*RExC_parse == '-') {
12641                         RExC_parse++;
12642                         isrel = 1;
12643                     }
12644                     if (hasbrace && !isDIGIT(*RExC_parse)) {
12645                         if (isrel) RExC_parse--;
12646                         RExC_parse -= 2;
12647                         goto parse_named_seq;
12648                     }
12649
12650                     if (RExC_parse >= RExC_end) {
12651                         goto unterminated_g;
12652                     }
12653                     num = S_backref_value(RExC_parse);
12654                     if (num == 0)
12655                         vFAIL("Reference to invalid group 0");
12656                     else if (num == I32_MAX) {
12657                          if (isDIGIT(*RExC_parse))
12658                             vFAIL("Reference to nonexistent group");
12659                         else
12660                           unterminated_g:
12661                             vFAIL("Unterminated \\g... pattern");
12662                     }
12663
12664                     if (isrel) {
12665                         num = RExC_npar - num;
12666                         if (num < 1)
12667                             vFAIL("Reference to nonexistent or unclosed group");
12668                     }
12669                 }
12670                 else {
12671                     num = S_backref_value(RExC_parse);
12672                     /* bare \NNN might be backref or octal - if it is larger
12673                      * than or equal RExC_npar then it is assumed to be an
12674                      * octal escape. Note RExC_npar is +1 from the actual
12675                      * number of parens. */
12676                     /* Note we do NOT check if num == I32_MAX here, as that is
12677                      * handled by the RExC_npar check */
12678
12679                     if (
12680                         /* any numeric escape < 10 is always a backref */
12681                         num > 9
12682                         /* any numeric escape < RExC_npar is a backref */
12683                         && num >= RExC_npar
12684                         /* cannot be an octal escape if it starts with 8 */
12685                         && *RExC_parse != '8'
12686                         /* cannot be an octal escape it it starts with 9 */
12687                         && *RExC_parse != '9'
12688                     )
12689                     {
12690                         /* Probably not a backref, instead likely to be an
12691                          * octal character escape, e.g. \35 or \777.
12692                          * The above logic should make it obvious why using
12693                          * octal escapes in patterns is problematic. - Yves */
12694                         RExC_parse = parse_start;
12695                         goto defchar;
12696                     }
12697                 }
12698
12699                 /* At this point RExC_parse points at a numeric escape like
12700                  * \12 or \88 or something similar, which we should NOT treat
12701                  * as an octal escape. It may or may not be a valid backref
12702                  * escape. For instance \88888888 is unlikely to be a valid
12703                  * backref. */
12704                 while (isDIGIT(*RExC_parse))
12705                     RExC_parse++;
12706                 if (hasbrace) {
12707                     if (*RExC_parse != '}')
12708                         vFAIL("Unterminated \\g{...} pattern");
12709                     RExC_parse++;
12710                 }
12711                 if (!SIZE_ONLY) {
12712                     if (num > (I32)RExC_rx->nparens)
12713                         vFAIL("Reference to nonexistent group");
12714                 }
12715                 RExC_sawback = 1;
12716                 ret = reganode(pRExC_state,
12717                                ((! FOLD)
12718                                  ? REF
12719                                  : (ASCII_FOLD_RESTRICTED)
12720                                    ? REFFA
12721                                    : (AT_LEAST_UNI_SEMANTICS)
12722                                      ? REFFU
12723                                      : (LOC)
12724                                        ? REFFL
12725                                        : REFF),
12726                                 num);
12727                 *flagp |= HASWIDTH;
12728
12729                 /* override incorrect value set in reganode MJD */
12730                 Set_Node_Offset(ret, parse_start);
12731                 Set_Node_Cur_Length(ret, parse_start-1);
12732                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
12733                                         FALSE /* Don't force to /x */ );
12734             }
12735             break;
12736         case '\0':
12737             if (RExC_parse >= RExC_end)
12738                 FAIL("Trailing \\");
12739             /* FALLTHROUGH */
12740         default:
12741             /* Do not generate "unrecognized" warnings here, we fall
12742                back into the quick-grab loop below */
12743             RExC_parse = parse_start;
12744             goto defchar;
12745         } /* end of switch on a \foo sequence */
12746         break;
12747
12748     case '#':
12749
12750         /* '#' comments should have been spaced over before this function was
12751          * called */
12752         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
12753         /*
12754         if (RExC_flags & RXf_PMf_EXTENDED) {
12755             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
12756             if (RExC_parse < RExC_end)
12757                 goto tryagain;
12758         }
12759         */
12760
12761         /* FALLTHROUGH */
12762
12763     default:
12764           defchar: {
12765
12766             /* Here, we have determined that the next thing is probably a
12767              * literal character.  RExC_parse points to the first byte of its
12768              * definition.  (It still may be an escape sequence that evaluates
12769              * to a single character) */
12770
12771             STRLEN len = 0;
12772             UV ender = 0;
12773             char *p;
12774             char *s;
12775 #define MAX_NODE_STRING_SIZE 127
12776             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
12777             char *s0;
12778             U8 upper_parse = MAX_NODE_STRING_SIZE;
12779             U8 node_type = compute_EXACTish(pRExC_state);
12780             bool next_is_quantifier;
12781             char * oldp = NULL;
12782
12783             /* We can convert EXACTF nodes to EXACTFU if they contain only
12784              * characters that match identically regardless of the target
12785              * string's UTF8ness.  The reason to do this is that EXACTF is not
12786              * trie-able, EXACTFU is.
12787              *
12788              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
12789              * contain only above-Latin1 characters (hence must be in UTF8),
12790              * which don't participate in folds with Latin1-range characters,
12791              * as the latter's folds aren't known until runtime.  (We don't
12792              * need to figure this out until pass 2) */
12793             bool maybe_exactfu = PASS2
12794                                && (node_type == EXACTF || node_type == EXACTFL);
12795
12796             /* If a folding node contains only code points that don't
12797              * participate in folds, it can be changed into an EXACT node,
12798              * which allows the optimizer more things to look for */
12799             bool maybe_exact;
12800
12801             ret = reg_node(pRExC_state, node_type);
12802
12803             /* In pass1, folded, we use a temporary buffer instead of the
12804              * actual node, as the node doesn't exist yet */
12805             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
12806
12807             s0 = s;
12808
12809           reparse:
12810
12811             /* We look for the EXACTFish to EXACT node optimizaton only if
12812              * folding.  (And we don't need to figure this out until pass 2).
12813              * XXX It might actually make sense to split the node into portions
12814              * that are exact and ones that aren't, so that we could later use
12815              * the exact ones to find the longest fixed and floating strings.
12816              * One would want to join them back into a larger node.  One could
12817              * use a pseudo regnode like 'EXACT_ORIG_FOLD' */
12818             maybe_exact = FOLD && PASS2;
12819
12820             /* XXX The node can hold up to 255 bytes, yet this only goes to
12821              * 127.  I (khw) do not know why.  Keeping it somewhat less than
12822              * 255 allows us to not have to worry about overflow due to
12823              * converting to utf8 and fold expansion, but that value is
12824              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
12825              * split up by this limit into a single one using the real max of
12826              * 255.  Even at 127, this breaks under rare circumstances.  If
12827              * folding, we do not want to split a node at a character that is a
12828              * non-final in a multi-char fold, as an input string could just
12829              * happen to want to match across the node boundary.  The join
12830              * would solve that problem if the join actually happens.  But a
12831              * series of more than two nodes in a row each of 127 would cause
12832              * the first join to succeed to get to 254, but then there wouldn't
12833              * be room for the next one, which could at be one of those split
12834              * multi-char folds.  I don't know of any fool-proof solution.  One
12835              * could back off to end with only a code point that isn't such a
12836              * non-final, but it is possible for there not to be any in the
12837              * entire node. */
12838
12839             assert(   ! UTF     /* Is at the beginning of a character */
12840                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
12841                    || UTF8_IS_START(UCHARAT(RExC_parse)));
12842
12843             for (p = RExC_parse;
12844                  len < upper_parse && p < RExC_end;
12845                  len++)
12846             {
12847                 oldp = p;
12848
12849                 /* White space has already been ignored */
12850                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
12851                        || ! is_PATWS_safe((p), RExC_end, UTF));
12852
12853                 switch ((U8)*p) {
12854                 case '^':
12855                 case '$':
12856                 case '.':
12857                 case '[':
12858                 case '(':
12859                 case ')':
12860                 case '|':
12861                     goto loopdone;
12862                 case '\\':
12863                     /* Literal Escapes Switch
12864
12865                        This switch is meant to handle escape sequences that
12866                        resolve to a literal character.
12867
12868                        Every escape sequence that represents something
12869                        else, like an assertion or a char class, is handled
12870                        in the switch marked 'Special Escapes' above in this
12871                        routine, but also has an entry here as anything that
12872                        isn't explicitly mentioned here will be treated as
12873                        an unescaped equivalent literal.
12874                     */
12875
12876                     switch ((U8)*++p) {
12877                     /* These are all the special escapes. */
12878                     case 'A':             /* Start assertion */
12879                     case 'b': case 'B':   /* Word-boundary assertion*/
12880                     case 'C':             /* Single char !DANGEROUS! */
12881                     case 'd': case 'D':   /* digit class */
12882                     case 'g': case 'G':   /* generic-backref, pos assertion */
12883                     case 'h': case 'H':   /* HORIZWS */
12884                     case 'k': case 'K':   /* named backref, keep marker */
12885                     case 'p': case 'P':   /* Unicode property */
12886                               case 'R':   /* LNBREAK */
12887                     case 's': case 'S':   /* space class */
12888                     case 'v': case 'V':   /* VERTWS */
12889                     case 'w': case 'W':   /* word class */
12890                     case 'X':             /* eXtended Unicode "combining
12891                                              character sequence" */
12892                     case 'z': case 'Z':   /* End of line/string assertion */
12893                         --p;
12894                         goto loopdone;
12895
12896                     /* Anything after here is an escape that resolves to a
12897                        literal. (Except digits, which may or may not)
12898                      */
12899                     case 'n':
12900                         ender = '\n';
12901                         p++;
12902                         break;
12903                     case 'N': /* Handle a single-code point named character. */
12904                         RExC_parse = p + 1;
12905                         if (! grok_bslash_N(pRExC_state,
12906                                             NULL,   /* Fail if evaluates to
12907                                                        anything other than a
12908                                                        single code point */
12909                                             &ender, /* The returned single code
12910                                                        point */
12911                                             NULL,   /* Don't need a count of
12912                                                        how many code points */
12913                                             flagp,
12914                                             RExC_strict,
12915                                             depth)
12916                         ) {
12917                             if (*flagp & NEED_UTF8)
12918                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
12919                             if (*flagp & RESTART_PASS1)
12920                                 return NULL;
12921
12922                             /* Here, it wasn't a single code point.  Go close
12923                              * up this EXACTish node.  The switch() prior to
12924                              * this switch handles the other cases */
12925                             RExC_parse = p = oldp;
12926                             goto loopdone;
12927                         }
12928                         p = RExC_parse;
12929                         if (ender > 0xff) {
12930                             REQUIRE_UTF8(flagp);
12931                         }
12932                         break;
12933                     case 'r':
12934                         ender = '\r';
12935                         p++;
12936                         break;
12937                     case 't':
12938                         ender = '\t';
12939                         p++;
12940                         break;
12941                     case 'f':
12942                         ender = '\f';
12943                         p++;
12944                         break;
12945                     case 'e':
12946                         ender = ESC_NATIVE;
12947                         p++;
12948                         break;
12949                     case 'a':
12950                         ender = '\a';
12951                         p++;
12952                         break;
12953                     case 'o':
12954                         {
12955                             UV result;
12956                             const char* error_msg;
12957
12958                             bool valid = grok_bslash_o(&p,
12959                                                        &result,
12960                                                        &error_msg,
12961                                                        PASS2, /* out warnings */
12962                                                        (bool) RExC_strict,
12963                                                        TRUE, /* Output warnings
12964                                                                 for non-
12965                                                                 portables */
12966                                                        UTF);
12967                             if (! valid) {
12968                                 RExC_parse = p; /* going to die anyway; point
12969                                                    to exact spot of failure */
12970                                 vFAIL(error_msg);
12971                             }
12972                             ender = result;
12973                             if (IN_ENCODING && ender < 0x100) {
12974                                 goto recode_encoding;
12975                             }
12976                             if (ender > 0xff) {
12977                                 REQUIRE_UTF8(flagp);
12978                             }
12979                             break;
12980                         }
12981                     case 'x':
12982                         {
12983                             UV result = UV_MAX; /* initialize to erroneous
12984                                                    value */
12985                             const char* error_msg;
12986
12987                             bool valid = grok_bslash_x(&p,
12988                                                        &result,
12989                                                        &error_msg,
12990                                                        PASS2, /* out warnings */
12991                                                        (bool) RExC_strict,
12992                                                        TRUE, /* Silence warnings
12993                                                                 for non-
12994                                                                 portables */
12995                                                        UTF);
12996                             if (! valid) {
12997                                 RExC_parse = p; /* going to die anyway; point
12998                                                    to exact spot of failure */
12999                                 vFAIL(error_msg);
13000                             }
13001                             ender = result;
13002
13003                             if (ender < 0x100) {
13004 #ifdef EBCDIC
13005                                 if (RExC_recode_x_to_native) {
13006                                     ender = LATIN1_TO_NATIVE(ender);
13007                                 }
13008                                 else
13009 #endif
13010                                 if (IN_ENCODING) {
13011                                     goto recode_encoding;
13012                                 }
13013                             }
13014                             else {
13015                                 REQUIRE_UTF8(flagp);
13016                             }
13017                             break;
13018                         }
13019                     case 'c':
13020                         p++;
13021                         ender = grok_bslash_c(*p++, PASS2);
13022                         break;
13023                     case '8': case '9': /* must be a backreference */
13024                         --p;
13025                         /* we have an escape like \8 which cannot be an octal escape
13026                          * so we exit the loop, and let the outer loop handle this
13027                          * escape which may or may not be a legitimate backref. */
13028                         goto loopdone;
13029                     case '1': case '2': case '3':case '4':
13030                     case '5': case '6': case '7':
13031                         /* When we parse backslash escapes there is ambiguity
13032                          * between backreferences and octal escapes. Any escape
13033                          * from \1 - \9 is a backreference, any multi-digit
13034                          * escape which does not start with 0 and which when
13035                          * evaluated as decimal could refer to an already
13036                          * parsed capture buffer is a back reference. Anything
13037                          * else is octal.
13038                          *
13039                          * Note this implies that \118 could be interpreted as
13040                          * 118 OR as "\11" . "8" depending on whether there
13041                          * were 118 capture buffers defined already in the
13042                          * pattern.  */
13043
13044                         /* NOTE, RExC_npar is 1 more than the actual number of
13045                          * parens we have seen so far, hence the < RExC_npar below. */
13046
13047                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13048                         {  /* Not to be treated as an octal constant, go
13049                                    find backref */
13050                             --p;
13051                             goto loopdone;
13052                         }
13053                         /* FALLTHROUGH */
13054                     case '0':
13055                         {
13056                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13057                             STRLEN numlen = 3;
13058                             ender = grok_oct(p, &numlen, &flags, NULL);
13059                             if (ender > 0xff) {
13060                                 REQUIRE_UTF8(flagp);
13061                             }
13062                             p += numlen;
13063                             if (PASS2   /* like \08, \178 */
13064                                 && numlen < 3
13065                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13066                             {
13067                                 reg_warn_non_literal_string(
13068                                          p + 1,
13069                                          form_short_octal_warning(p, numlen));
13070                             }
13071                         }
13072                         if (IN_ENCODING && ender < 0x100)
13073                             goto recode_encoding;
13074                         break;
13075                       recode_encoding:
13076                         if (! RExC_override_recoding) {
13077                             SV* enc = _get_encoding();
13078                             ender = reg_recode((U8)ender, &enc);
13079                             if (!enc && PASS2)
13080                                 ckWARNreg(p, "Invalid escape in the specified encoding");
13081                             REQUIRE_UTF8(flagp);
13082                         }
13083                         break;
13084                     case '\0':
13085                         if (p >= RExC_end)
13086                             FAIL("Trailing \\");
13087                         /* FALLTHROUGH */
13088                     default:
13089                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13090                             /* Include any left brace following the alpha to emphasize
13091                              * that it could be part of an escape at some point
13092                              * in the future */
13093                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13094                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13095                         }
13096                         goto normal_default;
13097                     } /* End of switch on '\' */
13098                     break;
13099                 case '{':
13100                     /* Currently we don't warn when the lbrace is at the start
13101                      * of a construct.  This catches it in the middle of a
13102                      * literal string, or when it's the first thing after
13103                      * something like "\b" */
13104                     if (! SIZE_ONLY
13105                         && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
13106                     {
13107                         ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
13108                     }
13109                     /*FALLTHROUGH*/
13110                 default:    /* A literal character */
13111                   normal_default:
13112                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13113                         STRLEN numlen;
13114                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13115                                                &numlen, UTF8_ALLOW_DEFAULT);
13116                         p += numlen;
13117                     }
13118                     else
13119                         ender = (U8) *p++;
13120                     break;
13121                 } /* End of switch on the literal */
13122
13123                 /* Here, have looked at the literal character and <ender>
13124                  * contains its ordinal, <p> points to the character after it.
13125                  * We need to check if the next non-ignored thing is a
13126                  * quantifier.  Move <p> to after anything that should be
13127                  * ignored, which, as a side effect, positions <p> for the next
13128                  * loop iteration */
13129                 skip_to_be_ignored_text(pRExC_state, &p,
13130                                         FALSE /* Don't force to /x */ );
13131
13132                 /* If the next thing is a quantifier, it applies to this
13133                  * character only, which means that this character has to be in
13134                  * its own node and can't just be appended to the string in an
13135                  * existing node, so if there are already other characters in
13136                  * the node, close the node with just them, and set up to do
13137                  * this character again next time through, when it will be the
13138                  * only thing in its new node */
13139                 if ((next_is_quantifier = (   LIKELY(p < RExC_end)
13140                                            && UNLIKELY(ISMULT2(p))))
13141                     && LIKELY(len))
13142                 {
13143                     p = oldp;
13144                     goto loopdone;
13145                 }
13146
13147                 /* Ready to add 'ender' to the node */
13148
13149                 if (! FOLD) {  /* The simple case, just append the literal */
13150
13151                     /* In the sizing pass, we need only the size of the
13152                      * character we are appending, hence we can delay getting
13153                      * its representation until PASS2. */
13154                     if (SIZE_ONLY) {
13155                         if (UTF) {
13156                             const STRLEN unilen = UVCHR_SKIP(ender);
13157                             s += unilen;
13158
13159                             /* We have to subtract 1 just below (and again in
13160                              * the corresponding PASS2 code) because the loop
13161                              * increments <len> each time, as all but this path
13162                              * (and one other) through it add a single byte to
13163                              * the EXACTish node.  But these paths would change
13164                              * len to be the correct final value, so cancel out
13165                              * the increment that follows */
13166                             len += unilen - 1;
13167                         }
13168                         else {
13169                             s++;
13170                         }
13171                     } else { /* PASS2 */
13172                       not_fold_common:
13173                         if (UTF) {
13174                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13175                             len += (char *) new_s - s - 1;
13176                             s = (char *) new_s;
13177                         }
13178                         else {
13179                             *(s++) = (char) ender;
13180                         }
13181                     }
13182                 }
13183                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13184
13185                     /* Here are folding under /l, and the code point is
13186                      * problematic.  First, we know we can't simplify things */
13187                     maybe_exact = FALSE;
13188                     maybe_exactfu = FALSE;
13189
13190                     /* A problematic code point in this context means that its
13191                      * fold isn't known until runtime, so we can't fold it now.
13192                      * (The non-problematic code points are the above-Latin1
13193                      * ones that fold to also all above-Latin1.  Their folds
13194                      * don't vary no matter what the locale is.) But here we
13195                      * have characters whose fold depends on the locale.
13196                      * Unlike the non-folding case above, we have to keep track
13197                      * of these in the sizing pass, so that we can make sure we
13198                      * don't split too-long nodes in the middle of a potential
13199                      * multi-char fold.  And unlike the regular fold case
13200                      * handled in the else clauses below, we don't actually
13201                      * fold and don't have special cases to consider.  What we
13202                      * do for both passes is the PASS2 code for non-folding */
13203                     goto not_fold_common;
13204                 }
13205                 else /* A regular FOLD code point */
13206                     if (! (   UTF
13207 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13208    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13209                                       || UNICODE_DOT_DOT_VERSION > 0)
13210                             /* See comments for join_exact() as to why we fold
13211                              * this non-UTF at compile time */
13212                             || (   node_type == EXACTFU
13213                                 && ender == LATIN_SMALL_LETTER_SHARP_S)
13214 #endif
13215                 )) {
13216                     /* Here, are folding and are not UTF-8 encoded; therefore
13217                      * the character must be in the range 0-255, and is not /l
13218                      * (Not /l because we already handled these under /l in
13219                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13220                     if (IS_IN_SOME_FOLD_L1(ender)) {
13221                         maybe_exact = FALSE;
13222
13223                         /* See if the character's fold differs between /d and
13224                          * /u.  This includes the multi-char fold SHARP S to
13225                          * 'ss' */
13226                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13227                             RExC_seen_unfolded_sharp_s = 1;
13228                             maybe_exactfu = FALSE;
13229                         }
13230                         else if (maybe_exactfu
13231                             && (PL_fold[ender] != PL_fold_latin1[ender]
13232 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13233    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13234                                       || UNICODE_DOT_DOT_VERSION > 0)
13235                                 || (   len > 0
13236                                     && isALPHA_FOLD_EQ(ender, 's')
13237                                     && isALPHA_FOLD_EQ(*(s-1), 's'))
13238 #endif
13239                         )) {
13240                             maybe_exactfu = FALSE;
13241                         }
13242                     }
13243
13244                     /* Even when folding, we store just the input character, as
13245                      * we have an array that finds its fold quickly */
13246                     *(s++) = (char) ender;
13247                 }
13248                 else {  /* FOLD, and UTF (or sharp s) */
13249                     /* Unlike the non-fold case, we do actually have to
13250                      * calculate the results here in pass 1.  This is for two
13251                      * reasons, the folded length may be longer than the
13252                      * unfolded, and we have to calculate how many EXACTish
13253                      * nodes it will take; and we may run out of room in a node
13254                      * in the middle of a potential multi-char fold, and have
13255                      * to back off accordingly.  */
13256
13257                     UV folded;
13258                     if (isASCII_uni(ender)) {
13259                         folded = toFOLD(ender);
13260                         *(s)++ = (U8) folded;
13261                     }
13262                     else {
13263                         STRLEN foldlen;
13264
13265                         folded = _to_uni_fold_flags(
13266                                      ender,
13267                                      (U8 *) s,
13268                                      &foldlen,
13269                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
13270                                                         ? FOLD_FLAGS_NOMIX_ASCII
13271                                                         : 0));
13272                         s += foldlen;
13273
13274                         /* The loop increments <len> each time, as all but this
13275                          * path (and one other) through it add a single byte to
13276                          * the EXACTish node.  But this one has changed len to
13277                          * be the correct final value, so subtract one to
13278                          * cancel out the increment that follows */
13279                         len += foldlen - 1;
13280                     }
13281                     /* If this node only contains non-folding code points so
13282                      * far, see if this new one is also non-folding */
13283                     if (maybe_exact) {
13284                         if (folded != ender) {
13285                             maybe_exact = FALSE;
13286                         }
13287                         else {
13288                             /* Here the fold is the original; we have to check
13289                              * further to see if anything folds to it */
13290                             if (_invlist_contains_cp(PL_utf8_foldable,
13291                                                         ender))
13292                             {
13293                                 maybe_exact = FALSE;
13294                             }
13295                         }
13296                     }
13297                     ender = folded;
13298                 }
13299
13300                 if (next_is_quantifier) {
13301
13302                     /* Here, the next input is a quantifier, and to get here,
13303                      * the current character is the only one in the node.
13304                      * Also, here <len> doesn't include the final byte for this
13305                      * character */
13306                     len++;
13307                     goto loopdone;
13308                 }
13309
13310             } /* End of loop through literal characters */
13311
13312             /* Here we have either exhausted the input or ran out of room in
13313              * the node.  (If we encountered a character that can't be in the
13314              * node, transfer is made directly to <loopdone>, and so we
13315              * wouldn't have fallen off the end of the loop.)  In the latter
13316              * case, we artificially have to split the node into two, because
13317              * we just don't have enough space to hold everything.  This
13318              * creates a problem if the final character participates in a
13319              * multi-character fold in the non-final position, as a match that
13320              * should have occurred won't, due to the way nodes are matched,
13321              * and our artificial boundary.  So back off until we find a non-
13322              * problematic character -- one that isn't at the beginning or
13323              * middle of such a fold.  (Either it doesn't participate in any
13324              * folds, or appears only in the final position of all the folds it
13325              * does participate in.)  A better solution with far fewer false
13326              * positives, and that would fill the nodes more completely, would
13327              * be to actually have available all the multi-character folds to
13328              * test against, and to back-off only far enough to be sure that
13329              * this node isn't ending with a partial one.  <upper_parse> is set
13330              * further below (if we need to reparse the node) to include just
13331              * up through that final non-problematic character that this code
13332              * identifies, so when it is set to less than the full node, we can
13333              * skip the rest of this */
13334             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
13335
13336                 const STRLEN full_len = len;
13337
13338                 assert(len >= MAX_NODE_STRING_SIZE);
13339
13340                 /* Here, <s> points to the final byte of the final character.
13341                  * Look backwards through the string until find a non-
13342                  * problematic character */
13343
13344                 if (! UTF) {
13345
13346                     /* This has no multi-char folds to non-UTF characters */
13347                     if (ASCII_FOLD_RESTRICTED) {
13348                         goto loopdone;
13349                     }
13350
13351                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
13352                     len = s - s0 + 1;
13353                 }
13354                 else {
13355                     if (!  PL_NonL1NonFinalFold) {
13356                         PL_NonL1NonFinalFold = _new_invlist_C_array(
13357                                         NonL1_Perl_Non_Final_Folds_invlist);
13358                     }
13359
13360                     /* Point to the first byte of the final character */
13361                     s = (char *) utf8_hop((U8 *) s, -1);
13362
13363                     while (s >= s0) {   /* Search backwards until find
13364                                            non-problematic char */
13365                         if (UTF8_IS_INVARIANT(*s)) {
13366
13367                             /* There are no ascii characters that participate
13368                              * in multi-char folds under /aa.  In EBCDIC, the
13369                              * non-ascii invariants are all control characters,
13370                              * so don't ever participate in any folds. */
13371                             if (ASCII_FOLD_RESTRICTED
13372                                 || ! IS_NON_FINAL_FOLD(*s))
13373                             {
13374                                 break;
13375                             }
13376                         }
13377                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
13378                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
13379                                                                   *s, *(s+1))))
13380                             {
13381                                 break;
13382                             }
13383                         }
13384                         else if (! _invlist_contains_cp(
13385                                         PL_NonL1NonFinalFold,
13386                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
13387                         {
13388                             break;
13389                         }
13390
13391                         /* Here, the current character is problematic in that
13392                          * it does occur in the non-final position of some
13393                          * fold, so try the character before it, but have to
13394                          * special case the very first byte in the string, so
13395                          * we don't read outside the string */
13396                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
13397                     } /* End of loop backwards through the string */
13398
13399                     /* If there were only problematic characters in the string,
13400                      * <s> will point to before s0, in which case the length
13401                      * should be 0, otherwise include the length of the
13402                      * non-problematic character just found */
13403                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
13404                 }
13405
13406                 /* Here, have found the final character, if any, that is
13407                  * non-problematic as far as ending the node without splitting
13408                  * it across a potential multi-char fold.  <len> contains the
13409                  * number of bytes in the node up-to and including that
13410                  * character, or is 0 if there is no such character, meaning
13411                  * the whole node contains only problematic characters.  In
13412                  * this case, give up and just take the node as-is.  We can't
13413                  * do any better */
13414                 if (len == 0) {
13415                     len = full_len;
13416
13417                     /* If the node ends in an 's' we make sure it stays EXACTF,
13418                      * as if it turns into an EXACTFU, it could later get
13419                      * joined with another 's' that would then wrongly match
13420                      * the sharp s */
13421                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
13422                     {
13423                         maybe_exactfu = FALSE;
13424                     }
13425                 } else {
13426
13427                     /* Here, the node does contain some characters that aren't
13428                      * problematic.  If one such is the final character in the
13429                      * node, we are done */
13430                     if (len == full_len) {
13431                         goto loopdone;
13432                     }
13433                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
13434
13435                         /* If the final character is problematic, but the
13436                          * penultimate is not, back-off that last character to
13437                          * later start a new node with it */
13438                         p = oldp;
13439                         goto loopdone;
13440                     }
13441
13442                     /* Here, the final non-problematic character is earlier
13443                      * in the input than the penultimate character.  What we do
13444                      * is reparse from the beginning, going up only as far as
13445                      * this final ok one, thus guaranteeing that the node ends
13446                      * in an acceptable character.  The reason we reparse is
13447                      * that we know how far in the character is, but we don't
13448                      * know how to correlate its position with the input parse.
13449                      * An alternate implementation would be to build that
13450                      * correlation as we go along during the original parse,
13451                      * but that would entail extra work for every node, whereas
13452                      * this code gets executed only when the string is too
13453                      * large for the node, and the final two characters are
13454                      * problematic, an infrequent occurrence.  Yet another
13455                      * possible strategy would be to save the tail of the
13456                      * string, and the next time regatom is called, initialize
13457                      * with that.  The problem with this is that unless you
13458                      * back off one more character, you won't be guaranteed
13459                      * regatom will get called again, unless regbranch,
13460                      * regpiece ... are also changed.  If you do back off that
13461                      * extra character, so that there is input guaranteed to
13462                      * force calling regatom, you can't handle the case where
13463                      * just the first character in the node is acceptable.  I
13464                      * (khw) decided to try this method which doesn't have that
13465                      * pitfall; if performance issues are found, we can do a
13466                      * combination of the current approach plus that one */
13467                     upper_parse = len;
13468                     len = 0;
13469                     s = s0;
13470                     goto reparse;
13471                 }
13472             }   /* End of verifying node ends with an appropriate char */
13473
13474           loopdone:   /* Jumped to when encounters something that shouldn't be
13475                          in the node */
13476
13477             /* I (khw) don't know if you can get here with zero length, but the
13478              * old code handled this situation by creating a zero-length EXACT
13479              * node.  Might as well be NOTHING instead */
13480             if (len == 0) {
13481                 OP(ret) = NOTHING;
13482             }
13483             else {
13484                 if (FOLD) {
13485                     /* If 'maybe_exact' is still set here, means there are no
13486                      * code points in the node that participate in folds;
13487                      * similarly for 'maybe_exactfu' and code points that match
13488                      * differently depending on UTF8ness of the target string
13489                      * (for /u), or depending on locale for /l */
13490                     if (maybe_exact) {
13491                         OP(ret) = (LOC)
13492                                   ? EXACTL
13493                                   : EXACT;
13494                     }
13495                     else if (maybe_exactfu) {
13496                         OP(ret) = (LOC)
13497                                   ? EXACTFLU8
13498                                   : EXACTFU;
13499                     }
13500                 }
13501                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
13502                                            FALSE /* Don't look to see if could
13503                                                     be turned into an EXACT
13504                                                     node, as we have already
13505                                                     computed that */
13506                                           );
13507             }
13508
13509             RExC_parse = p - 1;
13510             Set_Node_Cur_Length(ret, parse_start);
13511             RExC_parse = p;
13512             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13513                                     FALSE /* Don't force to /x */ );
13514             {
13515                 /* len is STRLEN which is unsigned, need to copy to signed */
13516                 IV iv = len;
13517                 if (iv < 0)
13518                     vFAIL("Internal disaster");
13519             }
13520
13521         } /* End of label 'defchar:' */
13522         break;
13523     } /* End of giant switch on input character */
13524
13525     return(ret);
13526 }
13527
13528
13529 STATIC void
13530 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
13531 {
13532     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13533      * sets up the bitmap and any flags, removing those code points from the
13534      * inversion list, setting it to NULL should it become completely empty */
13535
13536     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13537     assert(PL_regkind[OP(node)] == ANYOF);
13538
13539     ANYOF_BITMAP_ZERO(node);
13540     if (*invlist_ptr) {
13541
13542         /* This gets set if we actually need to modify things */
13543         bool change_invlist = FALSE;
13544
13545         UV start, end;
13546
13547         /* Start looking through *invlist_ptr */
13548         invlist_iterinit(*invlist_ptr);
13549         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13550             UV high;
13551             int i;
13552
13553             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13554                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13555             }
13556
13557             /* Quit if are above what we should change */
13558             if (start >= NUM_ANYOF_CODE_POINTS) {
13559                 break;
13560             }
13561
13562             change_invlist = TRUE;
13563
13564             /* Set all the bits in the range, up to the max that we are doing */
13565             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13566                    ? end
13567                    : NUM_ANYOF_CODE_POINTS - 1;
13568             for (i = start; i <= (int) high; i++) {
13569                 if (! ANYOF_BITMAP_TEST(node, i)) {
13570                     ANYOF_BITMAP_SET(node, i);
13571                 }
13572             }
13573         }
13574         invlist_iterfinish(*invlist_ptr);
13575
13576         /* Done with loop; remove any code points that are in the bitmap from
13577          * *invlist_ptr; similarly for code points above the bitmap if we have
13578          * a flag to match all of them anyways */
13579         if (change_invlist) {
13580             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13581         }
13582         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13583             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13584         }
13585
13586         /* If have completely emptied it, remove it completely */
13587         if (_invlist_len(*invlist_ptr) == 0) {
13588             SvREFCNT_dec_NN(*invlist_ptr);
13589             *invlist_ptr = NULL;
13590         }
13591     }
13592 }
13593
13594 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
13595    Character classes ([:foo:]) can also be negated ([:^foo:]).
13596    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
13597    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
13598    but trigger failures because they are currently unimplemented. */
13599
13600 #define POSIXCC_DONE(c)   ((c) == ':')
13601 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
13602 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
13603 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
13604
13605 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
13606 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
13607 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
13608
13609 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
13610
13611 /* 'posix_warnings' and 'warn_text' are names of variables in the following
13612  * routine. q.v. */
13613 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
13614         if (posix_warnings && (   posix_warnings != (AV **) -1              \
13615                                || (PASS2 && ckWARN(WARN_REGEXP))))          \
13616         {                                                                   \
13617             if (! warn_text) warn_text = newAV();                           \
13618             av_push(warn_text, Perl_newSVpvf(aTHX_                          \
13619                                              WARNING_PREFIX                 \
13620                                              text                           \
13621                                              REPORT_LOCATION,               \
13622                                              REPORT_LOCATION_ARGS(p)));     \
13623         }                                                                   \
13624     } STMT_END
13625
13626 STATIC int
13627 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
13628
13629     const char * const s,      /* Where the putative posix class begins.
13630                                   Normally, this is one past the '['.  This
13631                                   parameter exists so it can be somewhere
13632                                   besides RExC_parse. */
13633     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
13634                                   NULL */
13635     AV ** posix_warnings       /* Where to place any generated warnings, or -1
13636                                   if to output them, or NULL */
13637 )
13638 {
13639     /* This parses what the caller thinks may be one of the three POSIX
13640      * constructs:
13641      *  1) a character class, like [:blank:]
13642      *  2) a collating symbol, like [. .]
13643      *  3) an equivalence class, like [= =]
13644      * In the latter two cases, it croaks if it finds a syntactically legal
13645      * one, as these are not handled by Perl.
13646      *
13647      * The main purpose is to look for a POSIX character class.  It returns:
13648      *  a) the class number
13649      *      if it is a completely syntactically and semantically legal class.
13650      *      'updated_parse_ptr', if not NULL, is set to point to just after the
13651      *      closing ']' of the class
13652      *  b) OOB_NAMEDCLASS
13653      *      if it appears that one of the three POSIX constructs was meant, but
13654      *      its specification was somehow defective.  'updated_parse_ptr', if
13655      *      not NULL, is set to point to the character just after the end
13656      *      character of the class.  See below for handling of warnings.
13657      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
13658      *      if it  doesn't appear that a POSIX construct was intended.
13659      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
13660      *      raised.
13661      *
13662      * In b) there may be warnings and even errors generated.  What to do about
13663      * these is determined by the 'posix_warnings' parameter.  If it is NULL,
13664      * this call is treated as a check-only, scouting-out-the-territory call,
13665      * and no warnings nor errors are generated at all.  Otherwise, any errors
13666      * are raised if found.  If 'posix_warnings' is -1 (appropriately cast),
13667      * warnings are generated and displayed (in pass 2), just as they would be
13668      * for any other message of the same type from this file.  If it isn't NULL
13669      * and not -1, warnings aren't displayed, but instead an AV is generated
13670      * with all the warning messages (that aren't to be ignored) stored into
13671      * it, so that the caller can output them if it wants.  This is done in all
13672      * passes.  The reason for this is that the rest of the parsing is heavily
13673      * dependent on whether this routine found a valid posix class or not.  If
13674      * it did, the closing ']' is absorbed as part of the class.  If no class
13675      * or an invalid one is found, any ']' will be considered the terminator of
13676      * the outer bracketed character class, leading to very different results.
13677      * In particular, a '(?[ ])' construct will likely have a syntax error if
13678      * the class is parsed other than intended, and this will happen in pass1,
13679      * before the warnings would normally be output.  This mechanism allows the
13680      * caller to output those warnings in pass1 just before dieing, giving a
13681      * much better clue as to what is wrong.
13682      *
13683      * The reason for this function, and its complexity is that a bracketed
13684      * character class can contain just about anything.  But it's easy to
13685      * mistype the very specific posix class syntax but yielding a valid
13686      * regular bracketed class, so it silently gets compiled into something
13687      * quite unintended.
13688      *
13689      * The solution adopted here maintains backward compatibility except that
13690      * it adds a warning if it looks like a posix class was intended but
13691      * improperly specified.  The warning is not raised unless what is input
13692      * very closely resembles one of the 14 legal posix classes.  To do this,
13693      * it uses fuzzy parsing.  It calculates how many single-character edits it
13694      * would take to transform what was input into a legal posix class.  Only
13695      * if that number is quite small does it think that the intention was a
13696      * posix class.  Obviously these are heuristics, and there will be cases
13697      * where it errs on one side or another, and they can be tweaked as
13698      * experience informs.
13699      *
13700      * The syntax for a legal posix class is:
13701      *
13702      * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
13703      *
13704      * What this routine considers syntactically to be an intended posix class
13705      * is this (the comments indicate some restrictions that the pattern
13706      * doesn't show):
13707      *
13708      *  qr/(?x: \[?                         # The left bracket, possibly
13709      *                                      # omitted
13710      *          \h*                         # possibly followed by blanks
13711      *          (?: \^ \h* )?               # possibly a misplaced caret
13712      *          [:;]?                       # The opening class character,
13713      *                                      # possibly omitted.  A typo
13714      *                                      # semi-colon can also be used.
13715      *          \h*
13716      *          \^?                         # possibly a correctly placed
13717      *                                      # caret, but not if there was also
13718      *                                      # a misplaced one
13719      *          \h*
13720      *          .{3,15}                     # The class name.  If there are
13721      *                                      # deviations from the legal syntax,
13722      *                                      # its edit distance must be close
13723      *                                      # to a real class name in order
13724      *                                      # for it to be considered to be
13725      *                                      # an intended posix class.
13726      *          \h*
13727      *          [:punct:]?                  # The closing class character,
13728      *                                      # possibly omitted.  If not a colon
13729      *                                      # nor semi colon, the class name
13730      *                                      # must be even closer to a valid
13731      *                                      # one
13732      *          \h*
13733      *          \]?                         # The right bracket, possibly
13734      *                                      # omitted.
13735      *     )/
13736      *
13737      * In the above, \h must be ASCII-only.
13738      *
13739      * These are heuristics, and can be tweaked as field experience dictates.
13740      * There will be cases when someone didn't intend to specify a posix class
13741      * that this warns as being so.  The goal is to minimize these, while
13742      * maximizing the catching of things intended to be a posix class that
13743      * aren't parsed as such.
13744      */
13745
13746     const char* p             = s;
13747     const char * const e      = RExC_end;
13748     unsigned complement       = 0;      /* If to complement the class */
13749     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
13750     bool has_opening_bracket  = FALSE;
13751     bool has_opening_colon    = FALSE;
13752     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
13753                                                    valid class */
13754     AV* warn_text             = NULL;   /* any warning messages */
13755     const char * possible_end = NULL;   /* used for a 2nd parse pass */
13756     const char* name_start;             /* ptr to class name first char */
13757
13758     /* If the number of single-character typos the input name is away from a
13759      * legal name is no more than this number, it is considered to have meant
13760      * the legal name */
13761     int max_distance          = 2;
13762
13763     /* to store the name.  The size determines the maximum length before we
13764      * decide that no posix class was intended.  Should be at least
13765      * sizeof("alphanumeric") */
13766     UV input_text[15];
13767
13768     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
13769
13770     if (p >= e) {
13771         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
13772     }
13773
13774     if (*(p - 1) != '[') {
13775         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
13776         found_problem = TRUE;
13777     }
13778     else {
13779         has_opening_bracket = TRUE;
13780     }
13781
13782     /* They could be confused and think you can put spaces between the
13783      * components */
13784     if (isBLANK(*p)) {
13785         found_problem = TRUE;
13786
13787         do {
13788             p++;
13789         } while (p < e && isBLANK(*p));
13790
13791         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
13792     }
13793
13794     /* For [. .] and [= =].  These are quite different internally from [: :],
13795      * so they are handled separately.  */
13796     if (POSIXCC_NOTYET(*p)) {
13797         const char open_char  = *p;
13798         const char * temp_ptr = p + 1;
13799         unsigned int len      = 0;
13800
13801         /* These two constructs are not handled by perl, and if we find a
13802          * syntactically valid one, we croak.  It looks like just about any
13803          * byte can be in them, but they are likely very short, like [.ch.] to
13804          * denote a ligature 'ch' single character.  If we find something that
13805          * started out to look like one of these constructs, but isn't, we
13806          * break so that it can be checked for being a class name with a typo
13807          * of '.' or '=' instead of a colon */
13808         while (temp_ptr < e) {
13809             len++;
13810
13811             /* qr/[[.].]]/, for example, is valid.  But otherwise we quit on an
13812              * unexpected ']'.  It is possible, it appears, for such a ']' to
13813              * be not in the final position, but that's so unlikely that that
13814              * case is not handled. */
13815             if (*temp_ptr == ']' && temp_ptr[1] != open_char) {
13816                 break;
13817             }
13818
13819             /* XXX this could be cut down, but this value is certainly large
13820              * enough */
13821             if (len > 10) {
13822                 break;
13823             }
13824
13825             if (*temp_ptr == open_char) {
13826                 temp_ptr++;
13827                 if (*temp_ptr == ']') {
13828                     temp_ptr++;
13829                     if (! found_problem && posix_warnings) {
13830                         RExC_parse = (char *) temp_ptr;
13831                         vFAIL3("POSIX syntax [%c %c] is reserved for future "
13832                                "extensions", open_char, open_char);
13833                     }
13834
13835                     /* Here, the syntax wasn't completely valid, or else the
13836                      * call is to check-only */
13837                     if (updated_parse_ptr) {
13838                         *updated_parse_ptr = (char *) temp_ptr;
13839                     }
13840
13841                     return OOB_NAMEDCLASS;
13842                 }
13843             }
13844             else if (*temp_ptr == '\\') {
13845
13846                 /* A backslash is treate as like any other character, unless it
13847                  * precedes a comment starter.  XXX multiple backslashes in a
13848                  * row are not handled specially here, nor would they ever
13849                  * likely to be handled specially in one of these constructs */
13850                 if (temp_ptr[1] == '#' && (RExC_flags & RXf_PMf_EXTENDED)) {
13851                     temp_ptr++;
13852                 }
13853                 temp_ptr++;
13854             }
13855             else if (*temp_ptr == '#' && (RExC_flags & RXf_PMf_EXTENDED)) {
13856                 break;  /* Under no circumstances can we look at the interior
13857                            of a comment */
13858             }
13859             else if (*temp_ptr == '\n') {   /* And we don't allow newlines
13860                                                either as it's extremely
13861                                                unlikely that one could be in an
13862                                                intended class */
13863                 break;
13864             }
13865             else if (UTF && ! UTF8_IS_INVARIANT(*temp_ptr)) {
13866                 /* XXX Since perl will never handle multi-byte locales, except
13867                  * for UTF-8, we could break if we found a byte above latin1,
13868                  * but perhaps the person intended to use one. */
13869                 temp_ptr += UTF8SKIP(temp_ptr);
13870             }
13871             else {
13872                 temp_ptr++;
13873             }
13874         }
13875     }
13876
13877     /* Here, we think there is a possibility that a [: :] class was meant, and
13878      * we have the first real character.  It could be they think the '^' comes
13879      * first */
13880     if (*p == '^') {
13881         found_problem = TRUE;
13882         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
13883         complement = 1;
13884         p++;
13885
13886         if (isBLANK(*p)) {
13887             found_problem = TRUE;
13888
13889             do {
13890                 p++;
13891             } while (p < e && isBLANK(*p));
13892
13893             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
13894         }
13895     }
13896
13897     /* But the first character should be a colon, which they could have easily
13898      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
13899      * distinguish from a colon, so treat that as a colon).  */
13900     if (*p == ':') {
13901         p++;
13902         has_opening_colon = TRUE;
13903     }
13904     else if (*p == ';') {
13905         found_problem = TRUE;
13906         p++;
13907         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
13908         has_opening_colon = TRUE;
13909     }
13910     else {
13911         found_problem = TRUE;
13912         ADD_POSIX_WARNING(p, "there must be a starting ':'");
13913
13914         /* Consider an initial punctuation (not one of the recognized ones) to
13915          * be a left terminator */
13916         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
13917             p++;
13918         }
13919     }
13920
13921     /* They may think that you can put spaces between the components */
13922     if (isBLANK(*p)) {
13923         found_problem = TRUE;
13924
13925         do {
13926             p++;
13927         } while (p < e && isBLANK(*p));
13928
13929         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
13930     }
13931
13932     if (*p == '^') {
13933
13934         /* We consider something like [^:^alnum:]] to not have been intended to
13935          * be a posix class, but XXX maybe we should */
13936         if (complement) {
13937             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
13938         }
13939
13940         complement = 1;
13941         p++;
13942     }
13943
13944     /* Again, they may think that you can put spaces between the components */
13945     if (isBLANK(*p)) {
13946         found_problem = TRUE;
13947
13948         do {
13949             p++;
13950         } while (p < e && isBLANK(*p));
13951
13952         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
13953     }
13954
13955     if (*p == ']') {
13956
13957         /* XXX This ']' may be a typo, and something else was meant.  But
13958          * treating it as such creates enough complications, that that
13959          * possibility isn't currently considered here.  So we assume that the
13960          * ']' is what is intended, and if we've already found an initial '[',
13961          * this leaves this construct looking like [:] or [:^], which almost
13962          * certainly weren't intended to be posix classes */
13963         if (has_opening_bracket) {
13964             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
13965         }
13966
13967         /* But this function can be called when we parse the colon for
13968          * something like qr/[alpha:]]/, so we back up to look for the
13969          * beginning */
13970         p--;
13971
13972         if (*p == ';') {
13973             found_problem = TRUE;
13974             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
13975         }
13976         else if (*p != ':') {
13977
13978             /* XXX We are currently very restrictive here, so this code doesn't
13979              * consider the possibility that, say, /[alpha.]]/ was intended to
13980              * be a posix class. */
13981             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
13982         }
13983
13984         /* Here we have something like 'foo:]'.  There was no initial colon,
13985          * and we back up over 'foo.  XXX Unlike the going forward case, we
13986          * don't handle typos of non-word chars in the middle */
13987         has_opening_colon = FALSE;
13988         p--;
13989
13990         while (p > RExC_start && isWORDCHAR(*p)) {
13991             p--;
13992         }
13993         p++;
13994
13995         /* Here, we have positioned ourselves to where we think the first
13996          * character in the potential class is */
13997     }
13998
13999     /* Now the interior really starts.  There are certain key characters that
14000      * can end the interior, or these could just be typos.  To catch both
14001      * cases, we may have to do two passes.  In the first pass, we keep on
14002      * going unless we come to a sequence that matches
14003      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14004      * This means it takes a sequence to end the pass, so two typos in a row if
14005      * that wasn't what was intended.  If the class is perfectly formed, just
14006      * this one pass is needed.  We also stop if there are too many characters
14007      * being accumulated, but this number is deliberately set higher than any
14008      * real class.  It is set high enough so that someone who thinks that
14009      * 'alphanumeric' is a correct name would get warned that it wasn't.
14010      * While doing the pass, we keep track of where the key characters were in
14011      * it.  If we don't find an end to the class, and one of the key characters
14012      * was found, we redo the pass, but stop when we get to that character.
14013      * Thus the key character was considered a typo in the first pass, but a
14014      * terminator in the second.  If two key characters are found, we stop at
14015      * the second one in the first pass.  Again this can miss two typos, but
14016      * catches a single one
14017      *
14018      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14019      * point to the first key character.  For the second pass, it starts as -1.
14020      * */
14021
14022     name_start = p;
14023   parse_name:
14024     {
14025         bool has_blank               = FALSE;
14026         bool has_upper               = FALSE;
14027         bool has_terminating_colon   = FALSE;
14028         bool has_terminating_bracket = FALSE;
14029         bool has_semi_colon          = FALSE;
14030         unsigned int name_len        = 0;
14031         int punct_count              = 0;
14032
14033         while (p < e) {
14034
14035             /* Squeeze out blanks when looking up the class name below */
14036             if (isBLANK(*p) ) {
14037                 has_blank = TRUE;
14038                 found_problem = TRUE;
14039                 p++;
14040                 continue;
14041             }
14042
14043             /* The name will end with a punctuation */
14044             if (isPUNCT(*p)) {
14045                 const char * peek = p + 1;
14046
14047                 /* Treat any non-']' punctuation followed by a ']' (possibly
14048                  * with intervening blanks) as trying to terminate the class.
14049                  * ']]' is very likely to mean a class was intended (but
14050                  * missing the colon), but the warning message that gets
14051                  * generated shows the error position better if we exit the
14052                  * loop at the bottom (eventually), so skip it here. */
14053                 if (*p != ']') {
14054                     if (peek < e && isBLANK(*peek)) {
14055                         has_blank = TRUE;
14056                         found_problem = TRUE;
14057                         do {
14058                             peek++;
14059                         } while (peek < e && isBLANK(*peek));
14060                     }
14061
14062                     if (peek < e && *peek == ']') {
14063                         has_terminating_bracket = TRUE;
14064                         if (*p == ':') {
14065                             has_terminating_colon = TRUE;
14066                         }
14067                         else if (*p == ';') {
14068                             has_semi_colon = TRUE;
14069                             has_terminating_colon = TRUE;
14070                         }
14071                         else {
14072                             found_problem = TRUE;
14073                         }
14074                         p = peek + 1;
14075                         goto try_posix;
14076                     }
14077                 }
14078
14079                 /* Here we have punctuation we thought didn't end the class.
14080                  * Keep track of the position of the key characters that are
14081                  * more likely to have been class-enders */
14082                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14083
14084                     /* Allow just one such possible class-ender not actually
14085                      * ending the class. */
14086                     if (possible_end) {
14087                         break;
14088                     }
14089                     possible_end = p;
14090                 }
14091
14092                 /* If we have too many punctuation characters, no use in
14093                  * keeping going */
14094                 if (++punct_count > max_distance) {
14095                     break;
14096                 }
14097
14098                 /* Treat the punctuation as a typo. */
14099                 input_text[name_len++] = *p;
14100                 p++;
14101             }
14102             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14103                 input_text[name_len++] = toLOWER(*p);
14104                 has_upper = TRUE;
14105                 found_problem = TRUE;
14106                 p++;
14107             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14108                 input_text[name_len++] = *p;
14109                 p++;
14110             }
14111             else {
14112                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14113                 p+= UTF8SKIP(p);
14114             }
14115
14116             /* The declaration of 'input_text' is how long we allow a potential
14117              * class name to be, before saying they didn't mean a class name at
14118              * all */
14119             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14120                 break;
14121             }
14122         }
14123
14124         /* We get to here when the possible class name hasn't been properly
14125          * terminated before:
14126          *   1) we ran off the end of the pattern; or
14127          *   2) found two characters, each of which might have been intended to
14128          *      be the name's terminator
14129          *   3) found so many punctuation characters in the purported name,
14130          *      that the edit distance to a valid one is exceeded
14131          *   4) we decided it was more characters than anyone could have
14132          *      intended to be one. */
14133
14134         found_problem = TRUE;
14135
14136         /* In the final two cases, we know that looking up what we've
14137          * accumulated won't lead to a match, even a fuzzy one. */
14138         if (   name_len >= C_ARRAY_LENGTH(input_text)
14139             || punct_count > max_distance)
14140         {
14141             /* If there was an intermediate key character that could have been
14142              * an intended end, redo the parse, but stop there */
14143             if (possible_end && possible_end != (char *) -1) {
14144                 possible_end = (char *) -1; /* Special signal value to say
14145                                                we've done a first pass */
14146                 p = name_start;
14147                 goto parse_name;
14148             }
14149
14150             /* Otherwise, it can't have meant to have been a class */
14151             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14152         }
14153
14154         /* If we ran off the end, and the final character was a punctuation
14155          * one, back up one, to look at that final one just below.  Later, we
14156          * will restore the parse pointer if appropriate */
14157         if (name_len && p == e && isPUNCT(*(p-1))) {
14158             p--;
14159             name_len--;
14160         }
14161
14162         if (p < e && isPUNCT(*p)) {
14163             if (*p == ']') {
14164                 has_terminating_bracket = TRUE;
14165
14166                 /* If this is a 2nd ']', and the first one is just below this
14167                  * one, consider that to be the real terminator.  This gives a
14168                  * uniform and better positioning for the warning message  */
14169                 if (   possible_end
14170                     && possible_end != (char *) -1
14171                     && *possible_end == ']'
14172                     && name_len && input_text[name_len - 1] == ']')
14173                 {
14174                     name_len--;
14175                     p = possible_end;
14176
14177                     /* And this is actually equivalent to having done the 2nd
14178                      * pass now, so set it to not try again */
14179                     possible_end = (char *) -1;
14180                 }
14181             }
14182             else {
14183                 if (*p == ':') {
14184                     has_terminating_colon = TRUE;
14185                 }
14186                 else if (*p == ';') {
14187                     has_semi_colon = TRUE;
14188                     has_terminating_colon = TRUE;
14189                 }
14190                 p++;
14191             }
14192         }
14193
14194     try_posix:
14195
14196         /* Here, we have a class name to look up.  We can short circuit the
14197          * stuff below for short names that can't possibly be meant to be a
14198          * class name.  (We can do this on the first pass, as any second pass
14199          * will yield an even shorter name) */
14200         if (name_len < 3) {
14201             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14202         }
14203
14204         /* Find which class it is.  Initially switch on the length of the name.
14205          * */
14206         switch (name_len) {
14207             case 4:
14208                 if (memEQ(name_start, "word", 4)) {
14209                     /* this is not POSIX, this is the Perl \w */
14210                     class_number = ANYOF_WORDCHAR;
14211                 }
14212                 break;
14213             case 5:
14214                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14215                  *                        graph lower print punct space upper
14216                  * Offset 4 gives the best switch position.  */
14217                 switch (name_start[4]) {
14218                     case 'a':
14219                         if (memEQ(name_start, "alph", 4)) /* alpha */
14220                             class_number = ANYOF_ALPHA;
14221                         break;
14222                     case 'e':
14223                         if (memEQ(name_start, "spac", 4)) /* space */
14224                             class_number = ANYOF_SPACE;
14225                         break;
14226                     case 'h':
14227                         if (memEQ(name_start, "grap", 4)) /* graph */
14228                             class_number = ANYOF_GRAPH;
14229                         break;
14230                     case 'i':
14231                         if (memEQ(name_start, "asci", 4)) /* ascii */
14232                             class_number = ANYOF_ASCII;
14233                         break;
14234                     case 'k':
14235                         if (memEQ(name_start, "blan", 4)) /* blank */
14236                             class_number = ANYOF_BLANK;
14237                         break;
14238                     case 'l':
14239                         if (memEQ(name_start, "cntr", 4)) /* cntrl */
14240                             class_number = ANYOF_CNTRL;
14241                         break;
14242                     case 'm':
14243                         if (memEQ(name_start, "alnu", 4)) /* alnum */
14244                             class_number = ANYOF_ALPHANUMERIC;
14245                         break;
14246                     case 'r':
14247                         if (memEQ(name_start, "lowe", 4)) /* lower */
14248                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
14249                         else if (memEQ(name_start, "uppe", 4)) /* upper */
14250                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
14251                         break;
14252                     case 't':
14253                         if (memEQ(name_start, "digi", 4)) /* digit */
14254                             class_number = ANYOF_DIGIT;
14255                         else if (memEQ(name_start, "prin", 4)) /* print */
14256                             class_number = ANYOF_PRINT;
14257                         else if (memEQ(name_start, "punc", 4)) /* punct */
14258                             class_number = ANYOF_PUNCT;
14259                         break;
14260                 }
14261                 break;
14262             case 6:
14263                 if (memEQ(name_start, "xdigit", 6))
14264                     class_number = ANYOF_XDIGIT;
14265                 break;
14266         }
14267
14268         /* If the name exactly matches a posix class name the class number will
14269          * here be set to it, and the input almost certainly was meant to be a
14270          * posix class, so we can skip further checking.  If instead the syntax
14271          * is exactly correct, but the name isn't one of the legal ones, we
14272          * will return that as an error below.  But if neither of these apply,
14273          * it could be that no posix class was intended at all, or that one
14274          * was, but there was a typo.  We tease these apart by doing fuzzy
14275          * matching on the name */
14276         if (class_number == OOB_NAMEDCLASS && found_problem) {
14277             const UV posix_names[][6] = {
14278                                                 { 'a', 'l', 'n', 'u', 'm' },
14279                                                 { 'a', 'l', 'p', 'h', 'a' },
14280                                                 { 'a', 's', 'c', 'i', 'i' },
14281                                                 { 'b', 'l', 'a', 'n', 'k' },
14282                                                 { 'c', 'n', 't', 'r', 'l' },
14283                                                 { 'd', 'i', 'g', 'i', 't' },
14284                                                 { 'g', 'r', 'a', 'p', 'h' },
14285                                                 { 'l', 'o', 'w', 'e', 'r' },
14286                                                 { 'p', 'r', 'i', 'n', 't' },
14287                                                 { 'p', 'u', 'n', 'c', 't' },
14288                                                 { 's', 'p', 'a', 'c', 'e' },
14289                                                 { 'u', 'p', 'p', 'e', 'r' },
14290                                                 { 'w', 'o', 'r', 'd' },
14291                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
14292                                             };
14293             /* The names of the above all have added NULs to make them the same
14294              * size, so we need to also have the real lengths */
14295             const UV posix_name_lengths[] = {
14296                                                 sizeof("alnum") - 1,
14297                                                 sizeof("alpha") - 1,
14298                                                 sizeof("ascii") - 1,
14299                                                 sizeof("blank") - 1,
14300                                                 sizeof("cntrl") - 1,
14301                                                 sizeof("digit") - 1,
14302                                                 sizeof("graph") - 1,
14303                                                 sizeof("lower") - 1,
14304                                                 sizeof("print") - 1,
14305                                                 sizeof("punct") - 1,
14306                                                 sizeof("space") - 1,
14307                                                 sizeof("upper") - 1,
14308                                                 sizeof("word")  - 1,
14309                                                 sizeof("xdigit")- 1
14310                                             };
14311             unsigned int i;
14312             int temp_max = max_distance;    /* Use a temporary, so if we
14313                                                reparse, we haven't changed the
14314                                                outer one */
14315
14316             /* Use a smaller max edit distance if we are missing one of the
14317              * delimiters */
14318             if (   has_opening_bracket + has_opening_colon < 2
14319                 || has_terminating_bracket + has_terminating_colon < 2)
14320             {
14321                 temp_max--;
14322             }
14323
14324             /* See if the input name is close to a legal one */
14325             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
14326
14327                 /* Short circuit call if the lengths are too far apart to be
14328                  * able to match */
14329                 if (abs( (int) (name_len - posix_name_lengths[i]))
14330                     > temp_max)
14331                 {
14332                     continue;
14333                 }
14334
14335                 if (edit_distance(input_text,
14336                                   posix_names[i],
14337                                   name_len,
14338                                   posix_name_lengths[i],
14339                                   temp_max
14340                                  )
14341                     > -1)
14342                 { /* If it is close, it probably was intended to be a class */
14343                     goto probably_meant_to_be;
14344                 }
14345             }
14346
14347             /* Here the input name is not close enough to a valid class name
14348              * for us to consider it to be intended to be a posix class.  If
14349              * we haven't already done so, and the parse found a character that
14350              * could have been terminators for the name, but which we absorbed
14351              * as typos during the first pass, repeat the parse, signalling it
14352              * to stop at that character */
14353             if (possible_end && possible_end != (char *) -1) {
14354                 possible_end = (char *) -1;
14355                 p = name_start;
14356                 goto parse_name;
14357             }
14358
14359             /* Here neither pass found a close-enough class name */
14360             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14361         }
14362
14363     probably_meant_to_be:
14364
14365         /* Here we think that a posix specification was intended.  Update any
14366          * parse pointer */
14367         if (updated_parse_ptr) {
14368             *updated_parse_ptr = (char *) p;
14369         }
14370
14371         /* If a posix class name was intended but incorrectly specified, we
14372          * output or return the warnings */
14373         if (found_problem) {
14374
14375             /* We set flags for these issues in the parse loop above instead of
14376              * adding them to the list of warnings, because we can parse it
14377              * twice, and we only want one warning instance */
14378             if (has_upper) {
14379                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
14380             }
14381             if (has_blank) {
14382                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14383             }
14384             if (has_semi_colon) {
14385                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14386             }
14387             else if (! has_terminating_colon) {
14388                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
14389             }
14390             if (! has_terminating_bracket) {
14391                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
14392             }
14393
14394             if (warn_text) {
14395                 if (posix_warnings != (AV **) -1) {
14396                     *posix_warnings = warn_text;
14397                 }
14398                 else {
14399                     SV * msg;
14400                     while ((msg = av_shift(warn_text)) != &PL_sv_undef) {
14401                         Perl_warner(aTHX_ packWARN(WARN_REGEXP),
14402                                     "%s", SvPVX(msg));
14403                         SvREFCNT_dec_NN(msg);
14404                     }
14405                     SvREFCNT_dec_NN(warn_text);
14406                 }
14407             }
14408         }
14409         else if (class_number != OOB_NAMEDCLASS) {
14410             /* If it is a known class, return the class.  The class number
14411              * #defines are structured so each complement is +1 to the normal
14412              * one */
14413             return class_number + complement;
14414         }
14415         else if (posix_warnings) {
14416
14417             /* Here, it is an unrecognized class.  This is an error (unless the
14418             * call is to check only, which we've already handled above) */
14419             const char * const complement_string = (complement)
14420                                                    ? "^"
14421                                                    : "";
14422             RExC_parse = (char *) p;
14423             vFAIL3utf8f("POSIX class [:%s%"UTF8f":] unknown",
14424                         complement_string,
14425                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
14426         }
14427     }
14428
14429     return OOB_NAMEDCLASS;
14430 }
14431 #undef ADD_POSIX_WARNING
14432
14433 STATIC unsigned  int
14434 S_regex_set_precedence(const U8 my_operator) {
14435
14436     /* Returns the precedence in the (?[...]) construct of the input operator,
14437      * specified by its character representation.  The precedence follows
14438      * general Perl rules, but it extends this so that ')' and ']' have (low)
14439      * precedence even though they aren't really operators */
14440
14441     switch (my_operator) {
14442         case '!':
14443             return 5;
14444         case '&':
14445             return 4;
14446         case '^':
14447         case '|':
14448         case '+':
14449         case '-':
14450             return 3;
14451         case ')':
14452             return 2;
14453         case ']':
14454             return 1;
14455     }
14456
14457     NOT_REACHED; /* NOTREACHED */
14458     return 0;   /* Silence compiler warning */
14459 }
14460
14461 STATIC regnode *
14462 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
14463                     I32 *flagp, U32 depth,
14464                     char * const oregcomp_parse)
14465 {
14466     /* Handle the (?[...]) construct to do set operations */
14467
14468     U8 curchar;                     /* Current character being parsed */
14469     UV start, end;                  /* End points of code point ranges */
14470     SV* final = NULL;               /* The end result inversion list */
14471     SV* result_string;              /* 'final' stringified */
14472     AV* stack;                      /* stack of operators and operands not yet
14473                                        resolved */
14474     AV* fence_stack = NULL;         /* A stack containing the positions in
14475                                        'stack' of where the undealt-with left
14476                                        parens would be if they were actually
14477                                        put there */
14478     IV fence = 0;                   /* Position of where most recent undealt-
14479                                        with left paren in stack is; -1 if none.
14480                                      */
14481     STRLEN len;                     /* Temporary */
14482     regnode* node;                  /* Temporary, and final regnode returned by
14483                                        this function */
14484     const bool save_fold = FOLD;    /* Temporary */
14485     char *save_end, *save_parse;    /* Temporaries */
14486     const bool in_locale = LOC;     /* we turn off /l during processing */
14487     AV* posix_warnings = NULL;
14488
14489     GET_RE_DEBUG_FLAGS_DECL;
14490
14491     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
14492
14493     if (in_locale) {
14494         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
14495     }
14496
14497     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
14498                                          This is required so that the compile
14499                                          time values are valid in all runtime
14500                                          cases */
14501
14502     /* This will return only an ANYOF regnode, or (unlikely) something smaller
14503      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
14504      * call regclass to handle '[]' so as to not have to reinvent its parsing
14505      * rules here (throwing away the size it computes each time).  And, we exit
14506      * upon an unescaped ']' that isn't one ending a regclass.  To do both
14507      * these things, we need to realize that something preceded by a backslash
14508      * is escaped, so we have to keep track of backslashes */
14509     if (SIZE_ONLY) {
14510         UV depth = 0; /* how many nested (?[...]) constructs */
14511
14512         while (RExC_parse < RExC_end) {
14513             SV* current = NULL;
14514
14515             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14516                                     TRUE /* Force /x */ );
14517
14518             switch (*RExC_parse) {
14519                 case '?':
14520                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
14521                     /* FALLTHROUGH */
14522                 default:
14523                     break;
14524                 case '\\':
14525                     /* Skip past this, so the next character gets skipped, after
14526                      * the switch */
14527                     RExC_parse++;
14528                     if (*RExC_parse == 'c') {
14529                             /* Skip the \cX notation for control characters */
14530                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14531                     }
14532                     break;
14533
14534                 case '[':
14535                 {
14536                     /* See if this is a [:posix:] class. */
14537                     bool is_posix_class = (OOB_NAMEDCLASS
14538                             < handle_possible_posix(pRExC_state,
14539                                                 RExC_parse + 1,
14540                                                 NULL,
14541                                                 NULL));
14542                     /* If it is a posix class, leave the parse pointer at the
14543                      * '[' to fool regclass() into thinking it is part of a
14544                      * '[[:posix:]]'. */
14545                     if (! is_posix_class) {
14546                         RExC_parse++;
14547                     }
14548
14549                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
14550                      * if multi-char folds are allowed.  */
14551                     if (!regclass(pRExC_state, flagp,depth+1,
14552                                   is_posix_class, /* parse the whole char
14553                                                      class only if not a
14554                                                      posix class */
14555                                   FALSE, /* don't allow multi-char folds */
14556                                   TRUE, /* silence non-portable warnings. */
14557                                   TRUE, /* strict */
14558                                   FALSE, /* Require return to be an ANYOF */
14559                                   &current,
14560                                   &posix_warnings
14561                                  ))
14562                         FAIL2("panic: regclass returned NULL to handle_sets, "
14563                               "flags=%#"UVxf"", (UV) *flagp);
14564
14565                     /* function call leaves parse pointing to the ']', except
14566                      * if we faked it */
14567                     if (is_posix_class) {
14568                         RExC_parse--;
14569                     }
14570
14571                     SvREFCNT_dec(current);   /* In case it returned something */
14572                     break;
14573                 }
14574
14575                 case ']':
14576                     if (depth--) break;
14577                     RExC_parse++;
14578                     if (*RExC_parse == ')') {
14579                         node = reganode(pRExC_state, ANYOF, 0);
14580                         RExC_size += ANYOF_SKIP;
14581                         nextchar(pRExC_state);
14582                         Set_Node_Length(node,
14583                                 RExC_parse - oregcomp_parse + 1); /* MJD */
14584                         if (in_locale) {
14585                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
14586                         }
14587
14588                         return node;
14589                     }
14590                     goto no_close;
14591             }
14592
14593             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14594         }
14595
14596       no_close:
14597         /* We output the messages even if warnings are off, because we'll fail
14598          * the very next thing, and these give a likely diagnosis for that */
14599         if (posix_warnings) {
14600             SV * msg;
14601             while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
14602                 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
14603                 SvREFCNT_dec_NN(msg);
14604             }
14605             SvREFCNT_dec_NN(posix_warnings);
14606         }
14607
14608         FAIL("Syntax error in (?[...])");
14609     }
14610
14611     /* Pass 2 only after this. */
14612     Perl_ck_warner_d(aTHX_
14613         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
14614         "The regex_sets feature is experimental" REPORT_LOCATION,
14615         REPORT_LOCATION_ARGS(RExC_parse));
14616
14617     /* Everything in this construct is a metacharacter.  Operands begin with
14618      * either a '\' (for an escape sequence), or a '[' for a bracketed
14619      * character class.  Any other character should be an operator, or
14620      * parenthesis for grouping.  Both types of operands are handled by calling
14621      * regclass() to parse them.  It is called with a parameter to indicate to
14622      * return the computed inversion list.  The parsing here is implemented via
14623      * a stack.  Each entry on the stack is a single character representing one
14624      * of the operators; or else a pointer to an operand inversion list. */
14625
14626 #define IS_OPERATOR(a) SvIOK(a)
14627 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
14628
14629     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
14630      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
14631      * with pronouncing it called it Reverse Polish instead, but now that YOU
14632      * know how to pronounce it you can use the correct term, thus giving due
14633      * credit to the person who invented it, and impressing your geek friends.
14634      * Wikipedia says that the pronounciation of "Ł" has been changing so that
14635      * it is now more like an English initial W (as in wonk) than an L.)
14636      *
14637      * This means that, for example, 'a | b & c' is stored on the stack as
14638      *
14639      * c  [4]
14640      * b  [3]
14641      * &  [2]
14642      * a  [1]
14643      * |  [0]
14644      *
14645      * where the numbers in brackets give the stack [array] element number.
14646      * In this implementation, parentheses are not stored on the stack.
14647      * Instead a '(' creates a "fence" so that the part of the stack below the
14648      * fence is invisible except to the corresponding ')' (this allows us to
14649      * replace testing for parens, by using instead subtraction of the fence
14650      * position).  As new operands are processed they are pushed onto the stack
14651      * (except as noted in the next paragraph).  New operators of higher
14652      * precedence than the current final one are inserted on the stack before
14653      * the lhs operand (so that when the rhs is pushed next, everything will be
14654      * in the correct positions shown above.  When an operator of equal or
14655      * lower precedence is encountered in parsing, all the stacked operations
14656      * of equal or higher precedence are evaluated, leaving the result as the
14657      * top entry on the stack.  This makes higher precedence operations
14658      * evaluate before lower precedence ones, and causes operations of equal
14659      * precedence to left associate.
14660      *
14661      * The only unary operator '!' is immediately pushed onto the stack when
14662      * encountered.  When an operand is encountered, if the top of the stack is
14663      * a '!", the complement is immediately performed, and the '!' popped.  The
14664      * resulting value is treated as a new operand, and the logic in the
14665      * previous paragraph is executed.  Thus in the expression
14666      *      [a] + ! [b]
14667      * the stack looks like
14668      *
14669      * !
14670      * a
14671      * +
14672      *
14673      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
14674      * becomes
14675      *
14676      * !b
14677      * a
14678      * +
14679      *
14680      * A ')' is treated as an operator with lower precedence than all the
14681      * aforementioned ones, which causes all operations on the stack above the
14682      * corresponding '(' to be evaluated down to a single resultant operand.
14683      * Then the fence for the '(' is removed, and the operand goes through the
14684      * algorithm above, without the fence.
14685      *
14686      * A separate stack is kept of the fence positions, so that the position of
14687      * the latest so-far unbalanced '(' is at the top of it.
14688      *
14689      * The ']' ending the construct is treated as the lowest operator of all,
14690      * so that everything gets evaluated down to a single operand, which is the
14691      * result */
14692
14693     sv_2mortal((SV *)(stack = newAV()));
14694     sv_2mortal((SV *)(fence_stack = newAV()));
14695
14696     while (RExC_parse < RExC_end) {
14697         I32 top_index;              /* Index of top-most element in 'stack' */
14698         SV** top_ptr;               /* Pointer to top 'stack' element */
14699         SV* current = NULL;         /* To contain the current inversion list
14700                                        operand */
14701         SV* only_to_avoid_leaks;
14702
14703         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14704                                 TRUE /* Force /x */ );
14705         if (RExC_parse >= RExC_end) {
14706             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
14707         }
14708
14709         curchar = UCHARAT(RExC_parse);
14710
14711 redo_curchar:
14712
14713         top_index = av_tindex(stack);
14714
14715         switch (curchar) {
14716             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
14717             char stacked_operator;  /* The topmost operator on the 'stack'. */
14718             SV* lhs;                /* Operand to the left of the operator */
14719             SV* rhs;                /* Operand to the right of the operator */
14720             SV* fence_ptr;          /* Pointer to top element of the fence
14721                                        stack */
14722
14723             case '(':
14724
14725                 if (   RExC_parse < RExC_end - 1
14726                     && (UCHARAT(RExC_parse + 1) == '?'))
14727                 {
14728                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
14729                      * This happens when we have some thing like
14730                      *
14731                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
14732                      *   ...
14733                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
14734                      *
14735                      * Here we would be handling the interpolated
14736                      * '$thai_or_lao'.  We handle this by a recursive call to
14737                      * ourselves which returns the inversion list the
14738                      * interpolated expression evaluates to.  We use the flags
14739                      * from the interpolated pattern. */
14740                     U32 save_flags = RExC_flags;
14741                     const char * save_parse;
14742
14743                     RExC_parse += 2;        /* Skip past the '(?' */
14744                     save_parse = RExC_parse;
14745
14746                     /* Parse any flags for the '(?' */
14747                     parse_lparen_question_flags(pRExC_state);
14748
14749                     if (RExC_parse == save_parse  /* Makes sure there was at
14750                                                      least one flag (or else
14751                                                      this embedding wasn't
14752                                                      compiled) */
14753                         || RExC_parse >= RExC_end - 4
14754                         || UCHARAT(RExC_parse) != ':'
14755                         || UCHARAT(++RExC_parse) != '('
14756                         || UCHARAT(++RExC_parse) != '?'
14757                         || UCHARAT(++RExC_parse) != '[')
14758                     {
14759
14760                         /* In combination with the above, this moves the
14761                          * pointer to the point just after the first erroneous
14762                          * character (or if there are no flags, to where they
14763                          * should have been) */
14764                         if (RExC_parse >= RExC_end - 4) {
14765                             RExC_parse = RExC_end;
14766                         }
14767                         else if (RExC_parse != save_parse) {
14768                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
14769                         }
14770                         vFAIL("Expecting '(?flags:(?[...'");
14771                     }
14772
14773                     /* Recurse, with the meat of the embedded expression */
14774                     RExC_parse++;
14775                     (void) handle_regex_sets(pRExC_state, &current, flagp,
14776                                                     depth+1, oregcomp_parse);
14777
14778                     /* Here, 'current' contains the embedded expression's
14779                      * inversion list, and RExC_parse points to the trailing
14780                      * ']'; the next character should be the ')' */
14781                     RExC_parse++;
14782                     assert(UCHARAT(RExC_parse) == ')');
14783
14784                     /* Then the ')' matching the original '(' handled by this
14785                      * case: statement */
14786                     RExC_parse++;
14787                     assert(UCHARAT(RExC_parse) == ')');
14788
14789                     RExC_parse++;
14790                     RExC_flags = save_flags;
14791                     goto handle_operand;
14792                 }
14793
14794                 /* A regular '('.  Look behind for illegal syntax */
14795                 if (top_index - fence >= 0) {
14796                     /* If the top entry on the stack is an operator, it had
14797                      * better be a '!', otherwise the entry below the top
14798                      * operand should be an operator */
14799                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
14800                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
14801                         || (   IS_OPERAND(*top_ptr)
14802                             && (   top_index - fence < 1
14803                                 || ! (stacked_ptr = av_fetch(stack,
14804                                                              top_index - 1,
14805                                                              FALSE))
14806                                 || ! IS_OPERATOR(*stacked_ptr))))
14807                     {
14808                         RExC_parse++;
14809                         vFAIL("Unexpected '(' with no preceding operator");
14810                     }
14811                 }
14812
14813                 /* Stack the position of this undealt-with left paren */
14814                 fence = top_index + 1;
14815                 av_push(fence_stack, newSViv(fence));
14816                 break;
14817
14818             case '\\':
14819                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
14820                  * multi-char folds are allowed.  */
14821                 if (!regclass(pRExC_state, flagp,depth+1,
14822                               TRUE, /* means parse just the next thing */
14823                               FALSE, /* don't allow multi-char folds */
14824                               FALSE, /* don't silence non-portable warnings.  */
14825                               TRUE,  /* strict */
14826                               FALSE, /* Require return to be an ANYOF */
14827                               &current,
14828                               NULL))
14829                 {
14830                     FAIL2("panic: regclass returned NULL to handle_sets, "
14831                           "flags=%#"UVxf"", (UV) *flagp);
14832                 }
14833
14834                 /* regclass() will return with parsing just the \ sequence,
14835                  * leaving the parse pointer at the next thing to parse */
14836                 RExC_parse--;
14837                 goto handle_operand;
14838
14839             case '[':   /* Is a bracketed character class */
14840             {
14841                 /* See if this is a [:posix:] class. */
14842                 bool is_posix_class = (OOB_NAMEDCLASS
14843                             < handle_possible_posix(pRExC_state,
14844                                                 RExC_parse + 1,
14845                                                 NULL,
14846                                                 NULL));
14847                 /* If it is a posix class, leave the parse pointer at the '['
14848                  * to fool regclass() into thinking it is part of a
14849                  * '[[:posix:]]'. */
14850                 if (! is_posix_class) {
14851                     RExC_parse++;
14852                 }
14853
14854                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
14855                  * multi-char folds are allowed.  */
14856                 if (!regclass(pRExC_state, flagp,depth+1,
14857                                 is_posix_class, /* parse the whole char
14858                                                     class only if not a
14859                                                     posix class */
14860                                 FALSE, /* don't allow multi-char folds */
14861                                 TRUE, /* silence non-portable warnings. */
14862                                 TRUE, /* strict */
14863                                 FALSE, /* Require return to be an ANYOF */
14864                                 &current,
14865                                 NULL
14866                                 ))
14867                 {
14868                     FAIL2("panic: regclass returned NULL to handle_sets, "
14869                           "flags=%#"UVxf"", (UV) *flagp);
14870                 }
14871
14872                 /* function call leaves parse pointing to the ']', except if we
14873                  * faked it */
14874                 if (is_posix_class) {
14875                     RExC_parse--;
14876                 }
14877
14878                 goto handle_operand;
14879             }
14880
14881             case ']':
14882                 if (top_index >= 1) {
14883                     goto join_operators;
14884                 }
14885
14886                 /* Only a single operand on the stack: are done */
14887                 goto done;
14888
14889             case ')':
14890                 if (av_tindex(fence_stack) < 0) {
14891                     RExC_parse++;
14892                     vFAIL("Unexpected ')'");
14893                 }
14894
14895                  /* If at least two thing on the stack, treat this as an
14896                   * operator */
14897                 if (top_index - fence >= 1) {
14898                     goto join_operators;
14899                 }
14900
14901                 /* Here only a single thing on the fenced stack, and there is a
14902                  * fence.  Get rid of it */
14903                 fence_ptr = av_pop(fence_stack);
14904                 assert(fence_ptr);
14905                 fence = SvIV(fence_ptr) - 1;
14906                 SvREFCNT_dec_NN(fence_ptr);
14907                 fence_ptr = NULL;
14908
14909                 if (fence < 0) {
14910                     fence = 0;
14911                 }
14912
14913                 /* Having gotten rid of the fence, we pop the operand at the
14914                  * stack top and process it as a newly encountered operand */
14915                 current = av_pop(stack);
14916                 if (IS_OPERAND(current)) {
14917                     goto handle_operand;
14918                 }
14919
14920                 RExC_parse++;
14921                 goto bad_syntax;
14922
14923             case '&':
14924             case '|':
14925             case '+':
14926             case '-':
14927             case '^':
14928
14929                 /* These binary operators should have a left operand already
14930                  * parsed */
14931                 if (   top_index - fence < 0
14932                     || top_index - fence == 1
14933                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
14934                     || ! IS_OPERAND(*top_ptr))
14935                 {
14936                     goto unexpected_binary;
14937                 }
14938
14939                 /* If only the one operand is on the part of the stack visible
14940                  * to us, we just place this operator in the proper position */
14941                 if (top_index - fence < 2) {
14942
14943                     /* Place the operator before the operand */
14944
14945                     SV* lhs = av_pop(stack);
14946                     av_push(stack, newSVuv(curchar));
14947                     av_push(stack, lhs);
14948                     break;
14949                 }
14950
14951                 /* But if there is something else on the stack, we need to
14952                  * process it before this new operator if and only if the
14953                  * stacked operation has equal or higher precedence than the
14954                  * new one */
14955
14956              join_operators:
14957
14958                 /* The operator on the stack is supposed to be below both its
14959                  * operands */
14960                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
14961                     || IS_OPERAND(*stacked_ptr))
14962                 {
14963                     /* But if not, it's legal and indicates we are completely
14964                      * done if and only if we're currently processing a ']',
14965                      * which should be the final thing in the expression */
14966                     if (curchar == ']') {
14967                         goto done;
14968                     }
14969
14970                   unexpected_binary:
14971                     RExC_parse++;
14972                     vFAIL2("Unexpected binary operator '%c' with no "
14973                            "preceding operand", curchar);
14974                 }
14975                 stacked_operator = (char) SvUV(*stacked_ptr);
14976
14977                 if (regex_set_precedence(curchar)
14978                     > regex_set_precedence(stacked_operator))
14979                 {
14980                     /* Here, the new operator has higher precedence than the
14981                      * stacked one.  This means we need to add the new one to
14982                      * the stack to await its rhs operand (and maybe more
14983                      * stuff).  We put it before the lhs operand, leaving
14984                      * untouched the stacked operator and everything below it
14985                      * */
14986                     lhs = av_pop(stack);
14987                     assert(IS_OPERAND(lhs));
14988
14989                     av_push(stack, newSVuv(curchar));
14990                     av_push(stack, lhs);
14991                     break;
14992                 }
14993
14994                 /* Here, the new operator has equal or lower precedence than
14995                  * what's already there.  This means the operation already
14996                  * there should be performed now, before the new one. */
14997
14998                 rhs = av_pop(stack);
14999                 if (! IS_OPERAND(rhs)) {
15000
15001                     /* This can happen when a ! is not followed by an operand,
15002                      * like in /(?[\t &!])/ */
15003                     goto bad_syntax;
15004                 }
15005
15006                 lhs = av_pop(stack);
15007
15008                 if (! IS_OPERAND(lhs)) {
15009
15010                     /* This can happen when there is an empty (), like in
15011                      * /(?[[0]+()+])/ */
15012                     goto bad_syntax;
15013                 }
15014
15015                 switch (stacked_operator) {
15016                     case '&':
15017                         _invlist_intersection(lhs, rhs, &rhs);
15018                         break;
15019
15020                     case '|':
15021                     case '+':
15022                         _invlist_union(lhs, rhs, &rhs);
15023                         break;
15024
15025                     case '-':
15026                         _invlist_subtract(lhs, rhs, &rhs);
15027                         break;
15028
15029                     case '^':   /* The union minus the intersection */
15030                     {
15031                         SV* i = NULL;
15032                         SV* u = NULL;
15033                         SV* element;
15034
15035                         _invlist_union(lhs, rhs, &u);
15036                         _invlist_intersection(lhs, rhs, &i);
15037                         /* _invlist_subtract will overwrite rhs
15038                             without freeing what it already contains */
15039                         element = rhs;
15040                         _invlist_subtract(u, i, &rhs);
15041                         SvREFCNT_dec_NN(i);
15042                         SvREFCNT_dec_NN(u);
15043                         SvREFCNT_dec_NN(element);
15044                         break;
15045                     }
15046                 }
15047                 SvREFCNT_dec(lhs);
15048
15049                 /* Here, the higher precedence operation has been done, and the
15050                  * result is in 'rhs'.  We overwrite the stacked operator with
15051                  * the result.  Then we redo this code to either push the new
15052                  * operator onto the stack or perform any higher precedence
15053                  * stacked operation */
15054                 only_to_avoid_leaks = av_pop(stack);
15055                 SvREFCNT_dec(only_to_avoid_leaks);
15056                 av_push(stack, rhs);
15057                 goto redo_curchar;
15058
15059             case '!':   /* Highest priority, right associative */
15060
15061                 /* If what's already at the top of the stack is another '!",
15062                  * they just cancel each other out */
15063                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15064                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15065                 {
15066                     only_to_avoid_leaks = av_pop(stack);
15067                     SvREFCNT_dec(only_to_avoid_leaks);
15068                 }
15069                 else { /* Otherwise, since it's right associative, just push
15070                           onto the stack */
15071                     av_push(stack, newSVuv(curchar));
15072                 }
15073                 break;
15074
15075             default:
15076                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15077                 vFAIL("Unexpected character");
15078
15079           handle_operand:
15080
15081             /* Here 'current' is the operand.  If something is already on the
15082              * stack, we have to check if it is a !. */
15083             top_index = av_tindex(stack);   /* Code above may have altered the
15084                                              * stack in the time since we
15085                                              * earlier set 'top_index'. */
15086             if (top_index - fence >= 0) {
15087                 /* If the top entry on the stack is an operator, it had better
15088                  * be a '!', otherwise the entry below the top operand should
15089                  * be an operator */
15090                 top_ptr = av_fetch(stack, top_index, FALSE);
15091                 assert(top_ptr);
15092                 if (IS_OPERATOR(*top_ptr)) {
15093
15094                     /* The only permissible operator at the top of the stack is
15095                      * '!', which is applied immediately to this operand. */
15096                     curchar = (char) SvUV(*top_ptr);
15097                     if (curchar != '!') {
15098                         SvREFCNT_dec(current);
15099                         vFAIL2("Unexpected binary operator '%c' with no "
15100                                 "preceding operand", curchar);
15101                     }
15102
15103                     _invlist_invert(current);
15104
15105                     only_to_avoid_leaks = av_pop(stack);
15106                     SvREFCNT_dec(only_to_avoid_leaks);
15107                     top_index = av_tindex(stack);
15108
15109                     /* And we redo with the inverted operand.  This allows
15110                      * handling multiple ! in a row */
15111                     goto handle_operand;
15112                 }
15113                           /* Single operand is ok only for the non-binary ')'
15114                            * operator */
15115                 else if ((top_index - fence == 0 && curchar != ')')
15116                          || (top_index - fence > 0
15117                              && (! (stacked_ptr = av_fetch(stack,
15118                                                            top_index - 1,
15119                                                            FALSE))
15120                                  || IS_OPERAND(*stacked_ptr))))
15121                 {
15122                     SvREFCNT_dec(current);
15123                     vFAIL("Operand with no preceding operator");
15124                 }
15125             }
15126
15127             /* Here there was nothing on the stack or the top element was
15128              * another operand.  Just add this new one */
15129             av_push(stack, current);
15130
15131         } /* End of switch on next parse token */
15132
15133         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15134     } /* End of loop parsing through the construct */
15135
15136   done:
15137     if (av_tindex(fence_stack) >= 0) {
15138         vFAIL("Unmatched (");
15139     }
15140
15141     if (av_tindex(stack) < 0   /* Was empty */
15142         || ((final = av_pop(stack)) == NULL)
15143         || ! IS_OPERAND(final)
15144         || SvTYPE(final) != SVt_INVLIST
15145         || av_tindex(stack) >= 0)  /* More left on stack */
15146     {
15147       bad_syntax:
15148         SvREFCNT_dec(final);
15149         vFAIL("Incomplete expression within '(?[ ])'");
15150     }
15151
15152     /* Here, 'final' is the resultant inversion list from evaluating the
15153      * expression.  Return it if so requested */
15154     if (return_invlist) {
15155         *return_invlist = final;
15156         return END;
15157     }
15158
15159     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15160      * expecting a string of ranges and individual code points */
15161     invlist_iterinit(final);
15162     result_string = newSVpvs("");
15163     while (invlist_iternext(final, &start, &end)) {
15164         if (start == end) {
15165             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
15166         }
15167         else {
15168             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
15169                                                      start,          end);
15170         }
15171     }
15172
15173     /* About to generate an ANYOF (or similar) node from the inversion list we
15174      * have calculated */
15175     save_parse = RExC_parse;
15176     RExC_parse = SvPV(result_string, len);
15177     save_end = RExC_end;
15178     RExC_end = RExC_parse + len;
15179
15180     /* We turn off folding around the call, as the class we have constructed
15181      * already has all folding taken into consideration, and we don't want
15182      * regclass() to add to that */
15183     RExC_flags &= ~RXf_PMf_FOLD;
15184     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15185      * folds are allowed.  */
15186     node = regclass(pRExC_state, flagp,depth+1,
15187                     FALSE, /* means parse the whole char class */
15188                     FALSE, /* don't allow multi-char folds */
15189                     TRUE, /* silence non-portable warnings.  The above may very
15190                              well have generated non-portable code points, but
15191                              they're valid on this machine */
15192                     FALSE, /* similarly, no need for strict */
15193                     FALSE, /* Require return to be an ANYOF */
15194                     NULL,
15195                     NULL
15196                 );
15197     if (!node)
15198         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
15199                     PTR2UV(flagp));
15200
15201     /* Fix up the node type if we are in locale.  (We have pretended we are
15202      * under /u for the purposes of regclass(), as this construct will only
15203      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15204      * as to cause any warnings about bad locales to be output in regexec.c),
15205      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15206      * reason we above forbid optimization into something other than an ANYOF
15207      * node is simply to minimize the number of code changes in regexec.c.
15208      * Otherwise we would have to create new EXACTish node types and deal with
15209      * them.  This decision could be revisited should this construct become
15210      * popular.
15211      *
15212      * (One might think we could look at the resulting ANYOF node and suppress
15213      * the flag if everything is above 255, as those would be UTF-8 only,
15214      * but this isn't true, as the components that led to that result could
15215      * have been locale-affected, and just happen to cancel each other out
15216      * under UTF-8 locales.) */
15217     if (in_locale) {
15218         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15219
15220         assert(OP(node) == ANYOF);
15221
15222         OP(node) = ANYOFL;
15223         ANYOF_FLAGS(node)
15224                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
15225     }
15226
15227     if (save_fold) {
15228         RExC_flags |= RXf_PMf_FOLD;
15229     }
15230
15231     RExC_parse = save_parse + 1;
15232     RExC_end = save_end;
15233     SvREFCNT_dec_NN(final);
15234     SvREFCNT_dec_NN(result_string);
15235
15236     nextchar(pRExC_state);
15237     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
15238     return node;
15239 }
15240 #undef IS_OPERATOR
15241 #undef IS_OPERAND
15242
15243 STATIC void
15244 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
15245 {
15246     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
15247      * innocent-looking character class, like /[ks]/i won't have to go out to
15248      * disk to find the possible matches.
15249      *
15250      * This should be called only for a Latin1-range code points, cp, which is
15251      * known to be involved in a simple fold with other code points above
15252      * Latin1.  It would give false results if /aa has been specified.
15253      * Multi-char folds are outside the scope of this, and must be handled
15254      * specially.
15255      *
15256      * XXX It would be better to generate these via regen, in case a new
15257      * version of the Unicode standard adds new mappings, though that is not
15258      * really likely, and may be caught by the default: case of the switch
15259      * below. */
15260
15261     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
15262
15263     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
15264
15265     switch (cp) {
15266         case 'k':
15267         case 'K':
15268           *invlist =
15269              add_cp_to_invlist(*invlist, KELVIN_SIGN);
15270             break;
15271         case 's':
15272         case 'S':
15273           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
15274             break;
15275         case MICRO_SIGN:
15276           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
15277           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
15278             break;
15279         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
15280         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
15281           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
15282             break;
15283         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
15284           *invlist = add_cp_to_invlist(*invlist,
15285                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
15286             break;
15287
15288 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
15289
15290         case LATIN_SMALL_LETTER_SHARP_S:
15291           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
15292             break;
15293
15294 #endif
15295
15296 #if    UNICODE_MAJOR_VERSION < 3                                        \
15297    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
15298
15299         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
15300          * U+0131.  */
15301         case 'i':
15302         case 'I':
15303           *invlist =
15304              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
15305 #   if UNICODE_DOT_DOT_VERSION == 1
15306           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
15307 #   endif
15308             break;
15309 #endif
15310
15311         default:
15312             /* Use deprecated warning to increase the chances of this being
15313              * output */
15314             if (PASS2) {
15315                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
15316             }
15317             break;
15318     }
15319 }
15320
15321 STATIC AV *
15322 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
15323 {
15324     /* This adds the string scalar <multi_string> to the array
15325      * <multi_char_matches>.  <multi_string> is known to have exactly
15326      * <cp_count> code points in it.  This is used when constructing a
15327      * bracketed character class and we find something that needs to match more
15328      * than a single character.
15329      *
15330      * <multi_char_matches> is actually an array of arrays.  Each top-level
15331      * element is an array that contains all the strings known so far that are
15332      * the same length.  And that length (in number of code points) is the same
15333      * as the index of the top-level array.  Hence, the [2] element is an
15334      * array, each element thereof is a string containing TWO code points;
15335      * while element [3] is for strings of THREE characters, and so on.  Since
15336      * this is for multi-char strings there can never be a [0] nor [1] element.
15337      *
15338      * When we rewrite the character class below, we will do so such that the
15339      * longest strings are written first, so that it prefers the longest
15340      * matching strings first.  This is done even if it turns out that any
15341      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
15342      * Christiansen has agreed that this is ok.  This makes the test for the
15343      * ligature 'ffi' come before the test for 'ff', for example */
15344
15345     AV* this_array;
15346     AV** this_array_ptr;
15347
15348     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
15349
15350     if (! multi_char_matches) {
15351         multi_char_matches = newAV();
15352     }
15353
15354     if (av_exists(multi_char_matches, cp_count)) {
15355         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
15356         this_array = *this_array_ptr;
15357     }
15358     else {
15359         this_array = newAV();
15360         av_store(multi_char_matches, cp_count,
15361                  (SV*) this_array);
15362     }
15363     av_push(this_array, multi_string);
15364
15365     return multi_char_matches;
15366 }
15367
15368 /* The names of properties whose definitions are not known at compile time are
15369  * stored in this SV, after a constant heading.  So if the length has been
15370  * changed since initialization, then there is a run-time definition. */
15371 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
15372                                         (SvCUR(listsv) != initial_listsv_len)
15373
15374 /* There is a restricted set of white space characters that are legal when
15375  * ignoring white space in a bracketed character class.  This generates the
15376  * code to skip them.
15377  *
15378  * There is a line below that uses the same white space criteria but is outside
15379  * this macro.  Both here and there must use the same definition */
15380 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
15381     STMT_START {                                                        \
15382         if (do_skip) {                                                  \
15383             while (isBLANK_A(UCHARAT(p)))                               \
15384             {                                                           \
15385                 p++;                                                    \
15386             }                                                           \
15387         }                                                               \
15388     } STMT_END
15389
15390 STATIC regnode *
15391 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
15392                  const bool stop_at_1,  /* Just parse the next thing, don't
15393                                            look for a full character class */
15394                  bool allow_multi_folds,
15395                  const bool silence_non_portable,   /* Don't output warnings
15396                                                        about too large
15397                                                        characters */
15398                  const bool strict,
15399                  bool optimizable,                  /* ? Allow a non-ANYOF return
15400                                                        node */
15401                  SV** ret_invlist, /* Return an inversion list, not a node */
15402                  AV** return_posix_warnings
15403           )
15404 {
15405     /* parse a bracketed class specification.  Most of these will produce an
15406      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
15407      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
15408      * under /i with multi-character folds: it will be rewritten following the
15409      * paradigm of this example, where the <multi-fold>s are characters which
15410      * fold to multiple character sequences:
15411      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
15412      * gets effectively rewritten as:
15413      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
15414      * reg() gets called (recursively) on the rewritten version, and this
15415      * function will return what it constructs.  (Actually the <multi-fold>s
15416      * aren't physically removed from the [abcdefghi], it's just that they are
15417      * ignored in the recursion by means of a flag:
15418      * <RExC_in_multi_char_class>.)
15419      *
15420      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
15421      * characters, with the corresponding bit set if that character is in the
15422      * list.  For characters above this, a range list or swash is used.  There
15423      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
15424      * determinable at compile time
15425      *
15426      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
15427      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
15428      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
15429      */
15430
15431     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
15432     IV range = 0;
15433     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
15434     regnode *ret;
15435     STRLEN numlen;
15436     int namedclass = OOB_NAMEDCLASS;
15437     char *rangebegin = NULL;
15438     bool need_class = 0;
15439     SV *listsv = NULL;
15440     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
15441                                       than just initialized.  */
15442     SV* properties = NULL;    /* Code points that match \p{} \P{} */
15443     SV* posixes = NULL;     /* Code points that match classes like [:word:],
15444                                extended beyond the Latin1 range.  These have to
15445                                be kept separate from other code points for much
15446                                of this function because their handling  is
15447                                different under /i, and for most classes under
15448                                /d as well */
15449     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
15450                                separate for a while from the non-complemented
15451                                versions because of complications with /d
15452                                matching */
15453     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
15454                                   treated more simply than the general case,
15455                                   leading to less compilation and execution
15456                                   work */
15457     UV element_count = 0;   /* Number of distinct elements in the class.
15458                                Optimizations may be possible if this is tiny */
15459     AV * multi_char_matches = NULL; /* Code points that fold to more than one
15460                                        character; used under /i */
15461     UV n;
15462     char * stop_ptr = RExC_end;    /* where to stop parsing */
15463     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
15464                                                    space? */
15465
15466     /* Unicode properties are stored in a swash; this holds the current one
15467      * being parsed.  If this swash is the only above-latin1 component of the
15468      * character class, an optimization is to pass it directly on to the
15469      * execution engine.  Otherwise, it is set to NULL to indicate that there
15470      * are other things in the class that have to be dealt with at execution
15471      * time */
15472     SV* swash = NULL;           /* Code points that match \p{} \P{} */
15473
15474     /* Set if a component of this character class is user-defined; just passed
15475      * on to the engine */
15476     bool has_user_defined_property = FALSE;
15477
15478     /* inversion list of code points this node matches only when the target
15479      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
15480      * /d) */
15481     SV* has_upper_latin1_only_utf8_matches = NULL;
15482
15483     /* Inversion list of code points this node matches regardless of things
15484      * like locale, folding, utf8ness of the target string */
15485     SV* cp_list = NULL;
15486
15487     /* Like cp_list, but code points on this list need to be checked for things
15488      * that fold to/from them under /i */
15489     SV* cp_foldable_list = NULL;
15490
15491     /* Like cp_list, but code points on this list are valid only when the
15492      * runtime locale is UTF-8 */
15493     SV* only_utf8_locale_list = NULL;
15494
15495     /* In a range, if one of the endpoints is non-character-set portable,
15496      * meaning that it hard-codes a code point that may mean a different
15497      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
15498      * mnemonic '\t' which each mean the same character no matter which
15499      * character set the platform is on. */
15500     unsigned int non_portable_endpoint = 0;
15501
15502     /* Is the range unicode? which means on a platform that isn't 1-1 native
15503      * to Unicode (i.e. non-ASCII), each code point in it should be considered
15504      * to be a Unicode value.  */
15505     bool unicode_range = FALSE;
15506     bool invert = FALSE;    /* Is this class to be complemented */
15507
15508     bool warn_super = ALWAYS_WARN_SUPER;
15509
15510     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
15511         case we need to change the emitted regop to an EXACT. */
15512     const char * orig_parse = RExC_parse;
15513     const SSize_t orig_size = RExC_size;
15514     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
15515
15516     /* This variable is used to mark where in the input something that looks
15517      * like a POSIX construct ends.  During the parse, when something looks
15518      * like it could be such a construct is encountered, it is checked for
15519      * being one, but not if we've already checked this area of the input.
15520      * Only after this position is reached do we check again */
15521     char *not_posix_region_end = RExC_parse - 1;
15522
15523     GET_RE_DEBUG_FLAGS_DECL;
15524
15525     PERL_ARGS_ASSERT_REGCLASS;
15526 #ifndef DEBUGGING
15527     PERL_UNUSED_ARG(depth);
15528 #endif
15529
15530     DEBUG_PARSE("clas");
15531
15532 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
15533     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
15534                                    && UNICODE_DOT_DOT_VERSION == 0)
15535     allow_multi_folds = FALSE;
15536 #endif
15537
15538     if (return_posix_warnings == NULL) {
15539         return_posix_warnings = (AV **) -1;
15540     }
15541
15542     /* Assume we are going to generate an ANYOF node. */
15543     ret = reganode(pRExC_state,
15544                    (LOC)
15545                     ? ANYOFL
15546                     : ANYOF,
15547                    0);
15548
15549     if (SIZE_ONLY) {
15550         RExC_size += ANYOF_SKIP;
15551         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
15552     }
15553     else {
15554         ANYOF_FLAGS(ret) = 0;
15555
15556         RExC_emit += ANYOF_SKIP;
15557         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
15558         initial_listsv_len = SvCUR(listsv);
15559         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
15560     }
15561
15562     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15563
15564     assert(RExC_parse <= RExC_end);
15565
15566     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
15567         RExC_parse++;
15568         invert = TRUE;
15569         allow_multi_folds = FALSE;
15570         MARK_NAUGHTY(1);
15571         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15572     }
15573
15574     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
15575     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
15576         char *class_end;
15577         int maybe_class = handle_possible_posix(pRExC_state,
15578                                                 RExC_parse,
15579                                                 &class_end,
15580                                                 NULL);
15581         if (maybe_class >= OOB_NAMEDCLASS) {
15582             not_posix_region_end = class_end;
15583             if (PASS2 && return_posix_warnings == (AV **) -1) {
15584                 SAVEFREESV(RExC_rx_sv);
15585                 ckWARN4reg(class_end,
15586                         "POSIX syntax [%c %c] belongs inside character classes%s",
15587                         *RExC_parse, *RExC_parse,
15588                         (maybe_class == OOB_NAMEDCLASS)
15589                         ? ((POSIXCC_NOTYET(*RExC_parse))
15590                             ? " (but this one isn't implemented)"
15591                             : " (but this one isn't fully valid)")
15592                         : ""
15593                         );
15594                 (void)ReREFCNT_inc(RExC_rx_sv);
15595             }
15596         }
15597     }
15598
15599     /* If the caller wants us to just parse a single element, accomplish this
15600      * by faking the loop ending condition */
15601     if (stop_at_1 && RExC_end > RExC_parse) {
15602         stop_ptr = RExC_parse + 1;
15603     }
15604
15605     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
15606     if (UCHARAT(RExC_parse) == ']')
15607         goto charclassloop;
15608
15609     while (1) {
15610         if  (RExC_parse >= stop_ptr) {
15611             break;
15612         }
15613
15614         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15615
15616         if  (UCHARAT(RExC_parse) == ']') {
15617             break;
15618         }
15619
15620       charclassloop:
15621
15622         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
15623         save_value = value;
15624         save_prevvalue = prevvalue;
15625
15626         if (!range) {
15627             rangebegin = RExC_parse;
15628             element_count++;
15629             non_portable_endpoint = 0;
15630         }
15631         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
15632             value = utf8n_to_uvchr((U8*)RExC_parse,
15633                                    RExC_end - RExC_parse,
15634                                    &numlen, UTF8_ALLOW_DEFAULT);
15635             RExC_parse += numlen;
15636         }
15637         else
15638             value = UCHARAT(RExC_parse++);
15639
15640         if (value == '[') {
15641             namedclass = handle_possible_posix(pRExC_state,
15642                                                RExC_parse,
15643                                                &not_posix_region_end,
15644                                                return_posix_warnings);
15645             if (namedclass > OOB_NAMEDCLASS) {
15646                 RExC_parse = not_posix_region_end;
15647             }
15648             else {
15649                 namedclass = OOB_NAMEDCLASS;
15650             }
15651         }
15652         else if (   RExC_parse - 1 > not_posix_region_end
15653                  && MAYBE_POSIXCC(value))
15654         {
15655             (void) handle_possible_posix(
15656                         pRExC_state,
15657                         RExC_parse - 1,  /* -1 because parse has already been
15658                                             advanced */
15659                         &not_posix_region_end,
15660                         return_posix_warnings);
15661         }
15662         else if (value == '\\') {
15663             /* Is a backslash; get the code point of the char after it */
15664             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
15665                 value = utf8n_to_uvchr((U8*)RExC_parse,
15666                                    RExC_end - RExC_parse,
15667                                    &numlen, UTF8_ALLOW_DEFAULT);
15668                 RExC_parse += numlen;
15669             }
15670             else
15671                 value = UCHARAT(RExC_parse++);
15672
15673             /* Some compilers cannot handle switching on 64-bit integer
15674              * values, therefore value cannot be an UV.  Yes, this will
15675              * be a problem later if we want switch on Unicode.
15676              * A similar issue a little bit later when switching on
15677              * namedclass. --jhi */
15678
15679             /* If the \ is escaping white space when white space is being
15680              * skipped, it means that that white space is wanted literally, and
15681              * is already in 'value'.  Otherwise, need to translate the escape
15682              * into what it signifies. */
15683             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
15684
15685             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
15686             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
15687             case 's':   namedclass = ANYOF_SPACE;       break;
15688             case 'S':   namedclass = ANYOF_NSPACE;      break;
15689             case 'd':   namedclass = ANYOF_DIGIT;       break;
15690             case 'D':   namedclass = ANYOF_NDIGIT;      break;
15691             case 'v':   namedclass = ANYOF_VERTWS;      break;
15692             case 'V':   namedclass = ANYOF_NVERTWS;     break;
15693             case 'h':   namedclass = ANYOF_HORIZWS;     break;
15694             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
15695             case 'N':  /* Handle \N{NAME} in class */
15696                 {
15697                     const char * const backslash_N_beg = RExC_parse - 2;
15698                     int cp_count;
15699
15700                     if (! grok_bslash_N(pRExC_state,
15701                                         NULL,      /* No regnode */
15702                                         &value,    /* Yes single value */
15703                                         &cp_count, /* Multiple code pt count */
15704                                         flagp,
15705                                         strict,
15706                                         depth)
15707                     ) {
15708
15709                         if (*flagp & NEED_UTF8)
15710                             FAIL("panic: grok_bslash_N set NEED_UTF8");
15711                         if (*flagp & RESTART_PASS1)
15712                             return NULL;
15713
15714                         if (cp_count < 0) {
15715                             vFAIL("\\N in a character class must be a named character: \\N{...}");
15716                         }
15717                         else if (cp_count == 0) {
15718                             if (PASS2) {
15719                                 ckWARNreg(RExC_parse,
15720                                         "Ignoring zero length \\N{} in character class");
15721                             }
15722                         }
15723                         else { /* cp_count > 1 */
15724                             if (! RExC_in_multi_char_class) {
15725                                 if (invert || range || *RExC_parse == '-') {
15726                                     if (strict) {
15727                                         RExC_parse--;
15728                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
15729                                     }
15730                                     else if (PASS2) {
15731                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
15732                                     }
15733                                     break; /* <value> contains the first code
15734                                               point. Drop out of the switch to
15735                                               process it */
15736                                 }
15737                                 else {
15738                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
15739                                                  RExC_parse - backslash_N_beg);
15740                                     multi_char_matches
15741                                         = add_multi_match(multi_char_matches,
15742                                                           multi_char_N,
15743                                                           cp_count);
15744                                 }
15745                             }
15746                         } /* End of cp_count != 1 */
15747
15748                         /* This element should not be processed further in this
15749                          * class */
15750                         element_count--;
15751                         value = save_value;
15752                         prevvalue = save_prevvalue;
15753                         continue;   /* Back to top of loop to get next char */
15754                     }
15755
15756                     /* Here, is a single code point, and <value> contains it */
15757                     unicode_range = TRUE;   /* \N{} are Unicode */
15758                 }
15759                 break;
15760             case 'p':
15761             case 'P':
15762                 {
15763                 char *e;
15764
15765                 /* We will handle any undefined properties ourselves */
15766                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
15767                                        /* And we actually would prefer to get
15768                                         * the straight inversion list of the
15769                                         * swash, since we will be accessing it
15770                                         * anyway, to save a little time */
15771                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
15772
15773                 if (RExC_parse >= RExC_end)
15774                     vFAIL2("Empty \\%c", (U8)value);
15775                 if (*RExC_parse == '{') {
15776                     const U8 c = (U8)value;
15777                     e = strchr(RExC_parse, '}');
15778                     if (!e) {
15779                         RExC_parse++;
15780                         vFAIL2("Missing right brace on \\%c{}", c);
15781                     }
15782
15783                     RExC_parse++;
15784                     while (isSPACE(*RExC_parse)) {
15785                          RExC_parse++;
15786                     }
15787
15788                     if (UCHARAT(RExC_parse) == '^') {
15789
15790                         /* toggle.  (The rhs xor gets the single bit that
15791                          * differs between P and p; the other xor inverts just
15792                          * that bit) */
15793                         value ^= 'P' ^ 'p';
15794
15795                         RExC_parse++;
15796                         while (isSPACE(*RExC_parse)) {
15797                             RExC_parse++;
15798                         }
15799                     }
15800
15801                     if (e == RExC_parse)
15802                         vFAIL2("Empty \\%c{}", c);
15803
15804                     n = e - RExC_parse;
15805                     while (isSPACE(*(RExC_parse + n - 1)))
15806                         n--;
15807                 }   /* The \p isn't immediately followed by a '{' */
15808                 else if (! isALPHA(*RExC_parse)) {
15809                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15810                     vFAIL2("Character following \\%c must be '{' or a "
15811                            "single-character Unicode property name",
15812                            (U8) value);
15813                 }
15814                 else {
15815                     e = RExC_parse;
15816                     n = 1;
15817                 }
15818                 if (!SIZE_ONLY) {
15819                     SV* invlist;
15820                     char* name;
15821                     char* base_name;    /* name after any packages are stripped */
15822                     char* lookup_name = NULL;
15823                     const char * const colon_colon = "::";
15824
15825                     /* Try to get the definition of the property into
15826                      * <invlist>.  If /i is in effect, the effective property
15827                      * will have its name be <__NAME_i>.  The design is
15828                      * discussed in commit
15829                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
15830                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
15831                     if (FOLD) {
15832                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
15833                     }
15834
15835                     /* Look up the property name, and get its swash and
15836                      * inversion list, if the property is found  */
15837                     SvREFCNT_dec(swash); /* Free any left-overs */
15838                     swash = _core_swash_init("utf8",
15839                                              (lookup_name)
15840                                               ? lookup_name
15841                                               : name,
15842                                              &PL_sv_undef,
15843                                              1, /* binary */
15844                                              0, /* not tr/// */
15845                                              NULL, /* No inversion list */
15846                                              &swash_init_flags
15847                                             );
15848                     if (lookup_name) {
15849                         Safefree(lookup_name);
15850                     }
15851                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
15852                         HV* curpkg = (IN_PERL_COMPILETIME)
15853                                       ? PL_curstash
15854                                       : CopSTASH(PL_curcop);
15855                         UV final_n = n;
15856                         bool has_pkg;
15857
15858                         if (swash) {    /* Got a swash but no inversion list.
15859                                            Something is likely wrong that will
15860                                            be sorted-out later */
15861                             SvREFCNT_dec_NN(swash);
15862                             swash = NULL;
15863                         }
15864
15865                         /* Here didn't find it.  It could be a an error (like a
15866                          * typo) in specifying a Unicode property, or it could
15867                          * be a user-defined property that will be available at
15868                          * run-time.  The names of these must begin with 'In'
15869                          * or 'Is' (after any packages are stripped off).  So
15870                          * if not one of those, or if we accept only
15871                          * compile-time properties, is an error; otherwise add
15872                          * it to the list for run-time look up. */
15873                         if ((base_name = rninstr(name, name + n,
15874                                                  colon_colon, colon_colon + 2)))
15875                         { /* Has ::.  We know this must be a user-defined
15876                              property */
15877                             base_name += 2;
15878                             final_n -= base_name - name;
15879                             has_pkg = TRUE;
15880                         }
15881                         else {
15882                             base_name = name;
15883                             has_pkg = FALSE;
15884                         }
15885
15886                         if (   final_n < 3
15887                             || base_name[0] != 'I'
15888                             || (base_name[1] != 's' && base_name[1] != 'n')
15889                             || ret_invlist)
15890                         {
15891                             const char * const msg
15892                                 = (has_pkg)
15893                                   ? "Illegal user-defined property name"
15894                                   : "Can't find Unicode property definition";
15895                             RExC_parse = e + 1;
15896
15897                             /* diag_listed_as: Can't find Unicode property definition "%s" */
15898                             vFAIL3utf8f("%s \"%"UTF8f"\"",
15899                                 msg, UTF8fARG(UTF, n, name));
15900                         }
15901
15902                         /* If the property name doesn't already have a package
15903                          * name, add the current one to it so that it can be
15904                          * referred to outside it. [perl #121777] */
15905                         if (! has_pkg && curpkg) {
15906                             char* pkgname = HvNAME(curpkg);
15907                             if (strNE(pkgname, "main")) {
15908                                 char* full_name = Perl_form(aTHX_
15909                                                             "%s::%s",
15910                                                             pkgname,
15911                                                             name);
15912                                 n = strlen(full_name);
15913                                 Safefree(name);
15914                                 name = savepvn(full_name, n);
15915                             }
15916                         }
15917                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%"UTF8f"%s\n",
15918                                         (value == 'p' ? '+' : '!'),
15919                                         (FOLD) ? "__" : "",
15920                                         UTF8fARG(UTF, n, name),
15921                                         (FOLD) ? "_i" : "");
15922                         has_user_defined_property = TRUE;
15923                         optimizable = FALSE;    /* Will have to leave this an
15924                                                    ANYOF node */
15925
15926                         /* We don't know yet what this matches, so have to flag
15927                          * it */
15928                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
15929                     }
15930                     else {
15931
15932                         /* Here, did get the swash and its inversion list.  If
15933                          * the swash is from a user-defined property, then this
15934                          * whole character class should be regarded as such */
15935                         if (swash_init_flags
15936                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
15937                         {
15938                             has_user_defined_property = TRUE;
15939                         }
15940                         else if
15941                             /* We warn on matching an above-Unicode code point
15942                              * if the match would return true, except don't
15943                              * warn for \p{All}, which has exactly one element
15944                              * = 0 */
15945                             (_invlist_contains_cp(invlist, 0x110000)
15946                                 && (! (_invlist_len(invlist) == 1
15947                                        && *invlist_array(invlist) == 0)))
15948                         {
15949                             warn_super = TRUE;
15950                         }
15951
15952
15953                         /* Invert if asking for the complement */
15954                         if (value == 'P') {
15955                             _invlist_union_complement_2nd(properties,
15956                                                           invlist,
15957                                                           &properties);
15958
15959                             /* The swash can't be used as-is, because we've
15960                              * inverted things; delay removing it to here after
15961                              * have copied its invlist above */
15962                             SvREFCNT_dec_NN(swash);
15963                             swash = NULL;
15964                         }
15965                         else {
15966                             _invlist_union(properties, invlist, &properties);
15967                         }
15968                     }
15969                     Safefree(name);
15970                 }
15971                 RExC_parse = e + 1;
15972                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
15973                                                 named */
15974
15975                 /* \p means they want Unicode semantics */
15976                 REQUIRE_UNI_RULES(flagp, NULL);
15977                 }
15978                 break;
15979             case 'n':   value = '\n';                   break;
15980             case 'r':   value = '\r';                   break;
15981             case 't':   value = '\t';                   break;
15982             case 'f':   value = '\f';                   break;
15983             case 'b':   value = '\b';                   break;
15984             case 'e':   value = ESC_NATIVE;             break;
15985             case 'a':   value = '\a';                   break;
15986             case 'o':
15987                 RExC_parse--;   /* function expects to be pointed at the 'o' */
15988                 {
15989                     const char* error_msg;
15990                     bool valid = grok_bslash_o(&RExC_parse,
15991                                                &value,
15992                                                &error_msg,
15993                                                PASS2,   /* warnings only in
15994                                                            pass 2 */
15995                                                strict,
15996                                                silence_non_portable,
15997                                                UTF);
15998                     if (! valid) {
15999                         vFAIL(error_msg);
16000                     }
16001                 }
16002                 non_portable_endpoint++;
16003                 if (IN_ENCODING && value < 0x100) {
16004                     goto recode_encoding;
16005                 }
16006                 break;
16007             case 'x':
16008                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16009                 {
16010                     const char* error_msg;
16011                     bool valid = grok_bslash_x(&RExC_parse,
16012                                                &value,
16013                                                &error_msg,
16014                                                PASS2, /* Output warnings */
16015                                                strict,
16016                                                silence_non_portable,
16017                                                UTF);
16018                     if (! valid) {
16019                         vFAIL(error_msg);
16020                     }
16021                 }
16022                 non_portable_endpoint++;
16023                 if (IN_ENCODING && value < 0x100)
16024                     goto recode_encoding;
16025                 break;
16026             case 'c':
16027                 value = grok_bslash_c(*RExC_parse++, PASS2);
16028                 non_portable_endpoint++;
16029                 break;
16030             case '0': case '1': case '2': case '3': case '4':
16031             case '5': case '6': case '7':
16032                 {
16033                     /* Take 1-3 octal digits */
16034                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16035                     numlen = (strict) ? 4 : 3;
16036                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16037                     RExC_parse += numlen;
16038                     if (numlen != 3) {
16039                         if (strict) {
16040                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16041                             vFAIL("Need exactly 3 octal digits");
16042                         }
16043                         else if (! SIZE_ONLY /* like \08, \178 */
16044                                  && numlen < 3
16045                                  && RExC_parse < RExC_end
16046                                  && isDIGIT(*RExC_parse)
16047                                  && ckWARN(WARN_REGEXP))
16048                         {
16049                             SAVEFREESV(RExC_rx_sv);
16050                             reg_warn_non_literal_string(
16051                                  RExC_parse + 1,
16052                                  form_short_octal_warning(RExC_parse, numlen));
16053                             (void)ReREFCNT_inc(RExC_rx_sv);
16054                         }
16055                     }
16056                     non_portable_endpoint++;
16057                     if (IN_ENCODING && value < 0x100)
16058                         goto recode_encoding;
16059                     break;
16060                 }
16061               recode_encoding:
16062                 if (! RExC_override_recoding) {
16063                     SV* enc = _get_encoding();
16064                     value = reg_recode((U8)value, &enc);
16065                     if (!enc) {
16066                         if (strict) {
16067                             vFAIL("Invalid escape in the specified encoding");
16068                         }
16069                         else if (PASS2) {
16070                             ckWARNreg(RExC_parse,
16071                                   "Invalid escape in the specified encoding");
16072                         }
16073                     }
16074                     break;
16075                 }
16076             default:
16077                 /* Allow \_ to not give an error */
16078                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16079                     if (strict) {
16080                         vFAIL2("Unrecognized escape \\%c in character class",
16081                                (int)value);
16082                     }
16083                     else {
16084                         SAVEFREESV(RExC_rx_sv);
16085                         ckWARN2reg(RExC_parse,
16086                             "Unrecognized escape \\%c in character class passed through",
16087                             (int)value);
16088                         (void)ReREFCNT_inc(RExC_rx_sv);
16089                     }
16090                 }
16091                 break;
16092             }   /* End of switch on char following backslash */
16093         } /* end of handling backslash escape sequences */
16094
16095         /* Here, we have the current token in 'value' */
16096
16097         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
16098             U8 classnum;
16099
16100             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
16101              * literal, as is the character that began the false range, i.e.
16102              * the 'a' in the examples */
16103             if (range) {
16104                 if (!SIZE_ONLY) {
16105                     const int w = (RExC_parse >= rangebegin)
16106                                   ? RExC_parse - rangebegin
16107                                   : 0;
16108                     if (strict) {
16109                         vFAIL2utf8f(
16110                             "False [] range \"%"UTF8f"\"",
16111                             UTF8fARG(UTF, w, rangebegin));
16112                     }
16113                     else {
16114                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
16115                         ckWARN2reg(RExC_parse,
16116                             "False [] range \"%"UTF8f"\"",
16117                             UTF8fARG(UTF, w, rangebegin));
16118                         (void)ReREFCNT_inc(RExC_rx_sv);
16119                         cp_list = add_cp_to_invlist(cp_list, '-');
16120                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
16121                                                              prevvalue);
16122                     }
16123                 }
16124
16125                 range = 0; /* this was not a true range */
16126                 element_count += 2; /* So counts for three values */
16127             }
16128
16129             classnum = namedclass_to_classnum(namedclass);
16130
16131             if (LOC && namedclass < ANYOF_POSIXL_MAX
16132 #ifndef HAS_ISASCII
16133                 && classnum != _CC_ASCII
16134 #endif
16135             ) {
16136                 /* What the Posix classes (like \w, [:space:]) match in locale
16137                  * isn't knowable under locale until actual match time.  Room
16138                  * must be reserved (one time per outer bracketed class) to
16139                  * store such classes.  The space will contain a bit for each
16140                  * named class that is to be matched against.  This isn't
16141                  * needed for \p{} and pseudo-classes, as they are not affected
16142                  * by locale, and hence are dealt with separately */
16143                 if (! need_class) {
16144                     need_class = 1;
16145                     if (SIZE_ONLY) {
16146                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16147                     }
16148                     else {
16149                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16150                     }
16151                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
16152                     ANYOF_POSIXL_ZERO(ret);
16153
16154                     /* We can't change this into some other type of node
16155                      * (unless this is the only element, in which case there
16156                      * are nodes that mean exactly this) as has runtime
16157                      * dependencies */
16158                     optimizable = FALSE;
16159                 }
16160
16161                 /* Coverity thinks it is possible for this to be negative; both
16162                  * jhi and khw think it's not, but be safer */
16163                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16164                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
16165
16166                 /* See if it already matches the complement of this POSIX
16167                  * class */
16168                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16169                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
16170                                                             ? -1
16171                                                             : 1)))
16172                 {
16173                     posixl_matches_all = TRUE;
16174                     break;  /* No need to continue.  Since it matches both
16175                                e.g., \w and \W, it matches everything, and the
16176                                bracketed class can be optimized into qr/./s */
16177                 }
16178
16179                 /* Add this class to those that should be checked at runtime */
16180                 ANYOF_POSIXL_SET(ret, namedclass);
16181
16182                 /* The above-Latin1 characters are not subject to locale rules.
16183                  * Just add them, in the second pass, to the
16184                  * unconditionally-matched list */
16185                 if (! SIZE_ONLY) {
16186                     SV* scratch_list = NULL;
16187
16188                     /* Get the list of the above-Latin1 code points this
16189                      * matches */
16190                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
16191                                           PL_XPosix_ptrs[classnum],
16192
16193                                           /* Odd numbers are complements, like
16194                                            * NDIGIT, NASCII, ... */
16195                                           namedclass % 2 != 0,
16196                                           &scratch_list);
16197                     /* Checking if 'cp_list' is NULL first saves an extra
16198                      * clone.  Its reference count will be decremented at the
16199                      * next union, etc, or if this is the only instance, at the
16200                      * end of the routine */
16201                     if (! cp_list) {
16202                         cp_list = scratch_list;
16203                     }
16204                     else {
16205                         _invlist_union(cp_list, scratch_list, &cp_list);
16206                         SvREFCNT_dec_NN(scratch_list);
16207                     }
16208                     continue;   /* Go get next character */
16209                 }
16210             }
16211             else if (! SIZE_ONLY) {
16212
16213                 /* Here, not in pass1 (in that pass we skip calculating the
16214                  * contents of this class), and is /l, or is a POSIX class for
16215                  * which /l doesn't matter (or is a Unicode property, which is
16216                  * skipped here). */
16217                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
16218                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
16219
16220                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
16221                          * nor /l make a difference in what these match,
16222                          * therefore we just add what they match to cp_list. */
16223                         if (classnum != _CC_VERTSPACE) {
16224                             assert(   namedclass == ANYOF_HORIZWS
16225                                    || namedclass == ANYOF_NHORIZWS);
16226
16227                             /* It turns out that \h is just a synonym for
16228                              * XPosixBlank */
16229                             classnum = _CC_BLANK;
16230                         }
16231
16232                         _invlist_union_maybe_complement_2nd(
16233                                 cp_list,
16234                                 PL_XPosix_ptrs[classnum],
16235                                 namedclass % 2 != 0,    /* Complement if odd
16236                                                           (NHORIZWS, NVERTWS)
16237                                                         */
16238                                 &cp_list);
16239                     }
16240                 }
16241                 else if (UNI_SEMANTICS
16242                         || classnum == _CC_ASCII
16243                         || (DEPENDS_SEMANTICS && (classnum == _CC_DIGIT
16244                                                   || classnum == _CC_XDIGIT)))
16245                 {
16246                     /* We usually have to worry about /d and /a affecting what
16247                      * POSIX classes match, with special code needed for /d
16248                      * because we won't know until runtime what all matches.
16249                      * But there is no extra work needed under /u, and
16250                      * [:ascii:] is unaffected by /a and /d; and :digit: and
16251                      * :xdigit: don't have runtime differences under /d.  So we
16252                      * can special case these, and avoid some extra work below,
16253                      * and at runtime. */
16254                     _invlist_union_maybe_complement_2nd(
16255                                                      simple_posixes,
16256                                                      PL_XPosix_ptrs[classnum],
16257                                                      namedclass % 2 != 0,
16258                                                      &simple_posixes);
16259                 }
16260                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
16261                            complement and use nposixes */
16262                     SV** posixes_ptr = namedclass % 2 == 0
16263                                        ? &posixes
16264                                        : &nposixes;
16265                     _invlist_union_maybe_complement_2nd(
16266                                                      *posixes_ptr,
16267                                                      PL_XPosix_ptrs[classnum],
16268                                                      namedclass % 2 != 0,
16269                                                      posixes_ptr);
16270                 }
16271             }
16272         } /* end of namedclass \blah */
16273
16274         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16275
16276         /* If 'range' is set, 'value' is the ending of a range--check its
16277          * validity.  (If value isn't a single code point in the case of a
16278          * range, we should have figured that out above in the code that
16279          * catches false ranges).  Later, we will handle each individual code
16280          * point in the range.  If 'range' isn't set, this could be the
16281          * beginning of a range, so check for that by looking ahead to see if
16282          * the next real character to be processed is the range indicator--the
16283          * minus sign */
16284
16285         if (range) {
16286 #ifdef EBCDIC
16287             /* For unicode ranges, we have to test that the Unicode as opposed
16288              * to the native values are not decreasing.  (Above 255, there is
16289              * no difference between native and Unicode) */
16290             if (unicode_range && prevvalue < 255 && value < 255) {
16291                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
16292                     goto backwards_range;
16293                 }
16294             }
16295             else
16296 #endif
16297             if (prevvalue > value) /* b-a */ {
16298                 int w;
16299 #ifdef EBCDIC
16300               backwards_range:
16301 #endif
16302                 w = RExC_parse - rangebegin;
16303                 vFAIL2utf8f(
16304                     "Invalid [] range \"%"UTF8f"\"",
16305                     UTF8fARG(UTF, w, rangebegin));
16306                 NOT_REACHED; /* NOTREACHED */
16307             }
16308         }
16309         else {
16310             prevvalue = value; /* save the beginning of the potential range */
16311             if (! stop_at_1     /* Can't be a range if parsing just one thing */
16312                 && *RExC_parse == '-')
16313             {
16314                 char* next_char_ptr = RExC_parse + 1;
16315
16316                 /* Get the next real char after the '-' */
16317                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
16318
16319                 /* If the '-' is at the end of the class (just before the ']',
16320                  * it is a literal minus; otherwise it is a range */
16321                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
16322                     RExC_parse = next_char_ptr;
16323
16324                     /* a bad range like \w-, [:word:]- ? */
16325                     if (namedclass > OOB_NAMEDCLASS) {
16326                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
16327                             const int w = RExC_parse >= rangebegin
16328                                           ?  RExC_parse - rangebegin
16329                                           : 0;
16330                             if (strict) {
16331                                 vFAIL4("False [] range \"%*.*s\"",
16332                                     w, w, rangebegin);
16333                             }
16334                             else if (PASS2) {
16335                                 vWARN4(RExC_parse,
16336                                     "False [] range \"%*.*s\"",
16337                                     w, w, rangebegin);
16338                             }
16339                         }
16340                         if (!SIZE_ONLY) {
16341                             cp_list = add_cp_to_invlist(cp_list, '-');
16342                         }
16343                         element_count++;
16344                     } else
16345                         range = 1;      /* yeah, it's a range! */
16346                     continue;   /* but do it the next time */
16347                 }
16348             }
16349         }
16350
16351         if (namedclass > OOB_NAMEDCLASS) {
16352             continue;
16353         }
16354
16355         /* Here, we have a single value this time through the loop, and
16356          * <prevvalue> is the beginning of the range, if any; or <value> if
16357          * not. */
16358
16359         /* non-Latin1 code point implies unicode semantics.  Must be set in
16360          * pass1 so is there for the whole of pass 2 */
16361         if (value > 255) {
16362             REQUIRE_UNI_RULES(flagp, NULL);
16363         }
16364
16365         /* Ready to process either the single value, or the completed range.
16366          * For single-valued non-inverted ranges, we consider the possibility
16367          * of multi-char folds.  (We made a conscious decision to not do this
16368          * for the other cases because it can often lead to non-intuitive
16369          * results.  For example, you have the peculiar case that:
16370          *  "s s" =~ /^[^\xDF]+$/i => Y
16371          *  "ss"  =~ /^[^\xDF]+$/i => N
16372          *
16373          * See [perl #89750] */
16374         if (FOLD && allow_multi_folds && value == prevvalue) {
16375             if (value == LATIN_SMALL_LETTER_SHARP_S
16376                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
16377                                                         value)))
16378             {
16379                 /* Here <value> is indeed a multi-char fold.  Get what it is */
16380
16381                 U8 foldbuf[UTF8_MAXBYTES_CASE];
16382                 STRLEN foldlen;
16383
16384                 UV folded = _to_uni_fold_flags(
16385                                 value,
16386                                 foldbuf,
16387                                 &foldlen,
16388                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
16389                                                    ? FOLD_FLAGS_NOMIX_ASCII
16390                                                    : 0)
16391                                 );
16392
16393                 /* Here, <folded> should be the first character of the
16394                  * multi-char fold of <value>, with <foldbuf> containing the
16395                  * whole thing.  But, if this fold is not allowed (because of
16396                  * the flags), <fold> will be the same as <value>, and should
16397                  * be processed like any other character, so skip the special
16398                  * handling */
16399                 if (folded != value) {
16400
16401                     /* Skip if we are recursed, currently parsing the class
16402                      * again.  Otherwise add this character to the list of
16403                      * multi-char folds. */
16404                     if (! RExC_in_multi_char_class) {
16405                         STRLEN cp_count = utf8_length(foldbuf,
16406                                                       foldbuf + foldlen);
16407                         SV* multi_fold = sv_2mortal(newSVpvs(""));
16408
16409                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
16410
16411                         multi_char_matches
16412                                         = add_multi_match(multi_char_matches,
16413                                                           multi_fold,
16414                                                           cp_count);
16415
16416                     }
16417
16418                     /* This element should not be processed further in this
16419                      * class */
16420                     element_count--;
16421                     value = save_value;
16422                     prevvalue = save_prevvalue;
16423                     continue;
16424                 }
16425             }
16426         }
16427
16428         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
16429             if (range) {
16430
16431                 /* If the range starts above 255, everything is portable and
16432                  * likely to be so for any forseeable character set, so don't
16433                  * warn. */
16434                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
16435                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
16436                 }
16437                 else if (prevvalue != value) {
16438
16439                     /* Under strict, ranges that stop and/or end in an ASCII
16440                      * printable should have each end point be a portable value
16441                      * for it (preferably like 'A', but we don't warn if it is
16442                      * a (portable) Unicode name or code point), and the range
16443                      * must be be all digits or all letters of the same case.
16444                      * Otherwise, the range is non-portable and unclear as to
16445                      * what it contains */
16446                     if ((isPRINT_A(prevvalue) || isPRINT_A(value))
16447                         && (non_portable_endpoint
16448                             || ! ((isDIGIT_A(prevvalue) && isDIGIT_A(value))
16449                                    || (isLOWER_A(prevvalue) && isLOWER_A(value))
16450                                    || (isUPPER_A(prevvalue) && isUPPER_A(value)))))
16451                     {
16452                         vWARN(RExC_parse, "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\"");
16453                     }
16454                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
16455
16456                         /* But the nature of Unicode and languages mean we
16457                          * can't do the same checks for above-ASCII ranges,
16458                          * except in the case of digit ones.  These should
16459                          * contain only digits from the same group of 10.  The
16460                          * ASCII case is handled just above.  0x660 is the
16461                          * first digit character beyond ASCII.  Hence here, the
16462                          * range could be a range of digits.  Find out.  */
16463                         IV index_start = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16464                                                          prevvalue);
16465                         IV index_final = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16466                                                          value);
16467
16468                         /* If the range start and final points are in the same
16469                          * inversion list element, it means that either both
16470                          * are not digits, or both are digits in a consecutive
16471                          * sequence of digits.  (So far, Unicode has kept all
16472                          * such sequences as distinct groups of 10, but assert
16473                          * to make sure).  If the end points are not in the
16474                          * same element, neither should be a digit. */
16475                         if (index_start == index_final) {
16476                             assert(! ELEMENT_RANGE_MATCHES_INVLIST(index_start)
16477                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16478                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16479                                == 10)
16480                                /* But actually Unicode did have one group of 11
16481                                 * 'digits' in 5.2, so in case we are operating
16482                                 * on that version, let that pass */
16483                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16484                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16485                                 == 11
16486                                && invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16487                                 == 0x19D0)
16488                             );
16489                         }
16490                         else if ((index_start >= 0
16491                                   && ELEMENT_RANGE_MATCHES_INVLIST(index_start))
16492                                  || (index_final >= 0
16493                                      && ELEMENT_RANGE_MATCHES_INVLIST(index_final)))
16494                         {
16495                             vWARN(RExC_parse, "Ranges of digits should be from the same group of 10");
16496                         }
16497                     }
16498                 }
16499             }
16500             if ((! range || prevvalue == value) && non_portable_endpoint) {
16501                 if (isPRINT_A(value)) {
16502                     char literal[3];
16503                     unsigned d = 0;
16504                     if (isBACKSLASHED_PUNCT(value)) {
16505                         literal[d++] = '\\';
16506                     }
16507                     literal[d++] = (char) value;
16508                     literal[d++] = '\0';
16509
16510                     vWARN4(RExC_parse,
16511                            "\"%.*s\" is more clearly written simply as \"%s\"",
16512                            (int) (RExC_parse - rangebegin),
16513                            rangebegin,
16514                            literal
16515                         );
16516                 }
16517                 else if isMNEMONIC_CNTRL(value) {
16518                     vWARN4(RExC_parse,
16519                            "\"%.*s\" is more clearly written simply as \"%s\"",
16520                            (int) (RExC_parse - rangebegin),
16521                            rangebegin,
16522                            cntrl_to_mnemonic((U8) value)
16523                         );
16524                 }
16525             }
16526         }
16527
16528         /* Deal with this element of the class */
16529         if (! SIZE_ONLY) {
16530
16531 #ifndef EBCDIC
16532             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16533                                                      prevvalue, value);
16534 #else
16535             /* On non-ASCII platforms, for ranges that span all of 0..255, and
16536              * ones that don't require special handling, we can just add the
16537              * range like we do for ASCII platforms */
16538             if ((UNLIKELY(prevvalue == 0) && value >= 255)
16539                 || ! (prevvalue < 256
16540                       && (unicode_range
16541                           || (! non_portable_endpoint
16542                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
16543                                   || (isUPPER_A(prevvalue)
16544                                       && isUPPER_A(value)))))))
16545             {
16546                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16547                                                          prevvalue, value);
16548             }
16549             else {
16550                 /* Here, requires special handling.  This can be because it is
16551                  * a range whose code points are considered to be Unicode, and
16552                  * so must be individually translated into native, or because
16553                  * its a subrange of 'A-Z' or 'a-z' which each aren't
16554                  * contiguous in EBCDIC, but we have defined them to include
16555                  * only the "expected" upper or lower case ASCII alphabetics.
16556                  * Subranges above 255 are the same in native and Unicode, so
16557                  * can be added as a range */
16558                 U8 start = NATIVE_TO_LATIN1(prevvalue);
16559                 unsigned j;
16560                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
16561                 for (j = start; j <= end; j++) {
16562                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
16563                 }
16564                 if (value > 255) {
16565                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16566                                                              256, value);
16567                 }
16568             }
16569 #endif
16570         }
16571
16572         range = 0; /* this range (if it was one) is done now */
16573     } /* End of loop through all the text within the brackets */
16574
16575     /* If anything in the class expands to more than one character, we have to
16576      * deal with them by building up a substitute parse string, and recursively
16577      * calling reg() on it, instead of proceeding */
16578     if (multi_char_matches) {
16579         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
16580         I32 cp_count;
16581         STRLEN len;
16582         char *save_end = RExC_end;
16583         char *save_parse = RExC_parse;
16584         char *save_start = RExC_start;
16585         STRLEN prefix_end = 0;      /* We copy the character class after a
16586                                        prefix supplied here.  This is the size
16587                                        + 1 of that prefix */
16588         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
16589                                        a "|" */
16590         I32 reg_flags;
16591
16592         assert(! invert);
16593         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
16594
16595 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
16596            because too confusing */
16597         if (invert) {
16598             sv_catpv(substitute_parse, "(?:");
16599         }
16600 #endif
16601
16602         /* Look at the longest folds first */
16603         for (cp_count = av_tindex(multi_char_matches); cp_count > 0; cp_count--) {
16604
16605             if (av_exists(multi_char_matches, cp_count)) {
16606                 AV** this_array_ptr;
16607                 SV* this_sequence;
16608
16609                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
16610                                                  cp_count, FALSE);
16611                 while ((this_sequence = av_pop(*this_array_ptr)) !=
16612                                                                 &PL_sv_undef)
16613                 {
16614                     if (! first_time) {
16615                         sv_catpv(substitute_parse, "|");
16616                     }
16617                     first_time = FALSE;
16618
16619                     sv_catpv(substitute_parse, SvPVX(this_sequence));
16620                 }
16621             }
16622         }
16623
16624         /* If the character class contains anything else besides these
16625          * multi-character folds, have to include it in recursive parsing */
16626         if (element_count) {
16627             sv_catpv(substitute_parse, "|[");
16628             prefix_end = SvCUR(substitute_parse);
16629             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
16630
16631             /* Put in a closing ']' only if not going off the end, as otherwise
16632              * we are adding something that really isn't there */
16633             if (RExC_parse < RExC_end) {
16634                 sv_catpv(substitute_parse, "]");
16635             }
16636         }
16637
16638         sv_catpv(substitute_parse, ")");
16639 #if 0
16640         if (invert) {
16641             /* This is a way to get the parse to skip forward a whole named
16642              * sequence instead of matching the 2nd character when it fails the
16643              * first */
16644             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
16645         }
16646 #endif
16647
16648         /* Set up the data structure so that any errors will be properly
16649          * reported.  See the comments at the definition of
16650          * REPORT_LOCATION_ARGS for details */
16651         RExC_precomp_adj = orig_parse - RExC_precomp;
16652         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
16653         RExC_adjusted_start = RExC_start + prefix_end;
16654         RExC_end = RExC_parse + len;
16655         RExC_in_multi_char_class = 1;
16656         RExC_override_recoding = 1;
16657         RExC_emit = (regnode *)orig_emit;
16658
16659         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
16660
16661         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
16662
16663         /* And restore so can parse the rest of the pattern */
16664         RExC_parse = save_parse;
16665         RExC_start = RExC_adjusted_start = save_start;
16666         RExC_precomp_adj = 0;
16667         RExC_end = save_end;
16668         RExC_in_multi_char_class = 0;
16669         RExC_override_recoding = 0;
16670         SvREFCNT_dec_NN(multi_char_matches);
16671         return ret;
16672     }
16673
16674     /* Here, we've gone through the entire class and dealt with multi-char
16675      * folds.  We are now in a position that we can do some checks to see if we
16676      * can optimize this ANYOF node into a simpler one, even in Pass 1.
16677      * Currently we only do two checks:
16678      * 1) is in the unlikely event that the user has specified both, eg. \w and
16679      *    \W under /l, then the class matches everything.  (This optimization
16680      *    is done only to make the optimizer code run later work.)
16681      * 2) if the character class contains only a single element (including a
16682      *    single range), we see if there is an equivalent node for it.
16683      * Other checks are possible */
16684     if (   optimizable
16685         && ! ret_invlist   /* Can't optimize if returning the constructed
16686                               inversion list */
16687         && (UNLIKELY(posixl_matches_all) || element_count == 1))
16688     {
16689         U8 op = END;
16690         U8 arg = 0;
16691
16692         if (UNLIKELY(posixl_matches_all)) {
16693             op = SANY;
16694         }
16695         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
16696                                                    class, like \w or [:digit:]
16697                                                    or \p{foo} */
16698
16699             /* All named classes are mapped into POSIXish nodes, with its FLAG
16700              * argument giving which class it is */
16701             switch ((I32)namedclass) {
16702                 case ANYOF_UNIPROP:
16703                     break;
16704
16705                 /* These don't depend on the charset modifiers.  They always
16706                  * match under /u rules */
16707                 case ANYOF_NHORIZWS:
16708                 case ANYOF_HORIZWS:
16709                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
16710                     /* FALLTHROUGH */
16711
16712                 case ANYOF_NVERTWS:
16713                 case ANYOF_VERTWS:
16714                     op = POSIXU;
16715                     goto join_posix;
16716
16717                 /* The actual POSIXish node for all the rest depends on the
16718                  * charset modifier.  The ones in the first set depend only on
16719                  * ASCII or, if available on this platform, also locale */
16720                 case ANYOF_ASCII:
16721                 case ANYOF_NASCII:
16722 #ifdef HAS_ISASCII
16723                     op = (LOC) ? POSIXL : POSIXA;
16724 #else
16725                     op = POSIXA;
16726 #endif
16727                     goto join_posix;
16728
16729                 /* The following don't have any matches in the upper Latin1
16730                  * range, hence /d is equivalent to /u for them.  Making it /u
16731                  * saves some branches at runtime */
16732                 case ANYOF_DIGIT:
16733                 case ANYOF_NDIGIT:
16734                 case ANYOF_XDIGIT:
16735                 case ANYOF_NXDIGIT:
16736                     if (! DEPENDS_SEMANTICS) {
16737                         goto treat_as_default;
16738                     }
16739
16740                     op = POSIXU;
16741                     goto join_posix;
16742
16743                 /* The following change to CASED under /i */
16744                 case ANYOF_LOWER:
16745                 case ANYOF_NLOWER:
16746                 case ANYOF_UPPER:
16747                 case ANYOF_NUPPER:
16748                     if (FOLD) {
16749                         namedclass = ANYOF_CASED + (namedclass % 2);
16750                     }
16751                     /* FALLTHROUGH */
16752
16753                 /* The rest have more possibilities depending on the charset.
16754                  * We take advantage of the enum ordering of the charset
16755                  * modifiers to get the exact node type, */
16756                 default:
16757                   treat_as_default:
16758                     op = POSIXD + get_regex_charset(RExC_flags);
16759                     if (op > POSIXA) { /* /aa is same as /a */
16760                         op = POSIXA;
16761                     }
16762
16763                   join_posix:
16764                     /* The odd numbered ones are the complements of the
16765                      * next-lower even number one */
16766                     if (namedclass % 2 == 1) {
16767                         invert = ! invert;
16768                         namedclass--;
16769                     }
16770                     arg = namedclass_to_classnum(namedclass);
16771                     break;
16772             }
16773         }
16774         else if (value == prevvalue) {
16775
16776             /* Here, the class consists of just a single code point */
16777
16778             if (invert) {
16779                 if (! LOC && value == '\n') {
16780                     op = REG_ANY; /* Optimize [^\n] */
16781                     *flagp |= HASWIDTH|SIMPLE;
16782                     MARK_NAUGHTY(1);
16783                 }
16784             }
16785             else if (value < 256 || UTF) {
16786
16787                 /* Optimize a single value into an EXACTish node, but not if it
16788                  * would require converting the pattern to UTF-8. */
16789                 op = compute_EXACTish(pRExC_state);
16790             }
16791         } /* Otherwise is a range */
16792         else if (! LOC) {   /* locale could vary these */
16793             if (prevvalue == '0') {
16794                 if (value == '9') {
16795                     arg = _CC_DIGIT;
16796                     op = POSIXA;
16797                 }
16798             }
16799             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
16800                 /* We can optimize A-Z or a-z, but not if they could match
16801                  * something like the KELVIN SIGN under /i. */
16802                 if (prevvalue == 'A') {
16803                     if (value == 'Z'
16804 #ifdef EBCDIC
16805                         && ! non_portable_endpoint
16806 #endif
16807                     ) {
16808                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
16809                         op = POSIXA;
16810                     }
16811                 }
16812                 else if (prevvalue == 'a') {
16813                     if (value == 'z'
16814 #ifdef EBCDIC
16815                         && ! non_portable_endpoint
16816 #endif
16817                     ) {
16818                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
16819                         op = POSIXA;
16820                     }
16821                 }
16822             }
16823         }
16824
16825         /* Here, we have changed <op> away from its initial value iff we found
16826          * an optimization */
16827         if (op != END) {
16828
16829             /* Throw away this ANYOF regnode, and emit the calculated one,
16830              * which should correspond to the beginning, not current, state of
16831              * the parse */
16832             const char * cur_parse = RExC_parse;
16833             RExC_parse = (char *)orig_parse;
16834             if ( SIZE_ONLY) {
16835                 if (! LOC) {
16836
16837                     /* To get locale nodes to not use the full ANYOF size would
16838                      * require moving the code above that writes the portions
16839                      * of it that aren't in other nodes to after this point.
16840                      * e.g.  ANYOF_POSIXL_SET */
16841                     RExC_size = orig_size;
16842                 }
16843             }
16844             else {
16845                 RExC_emit = (regnode *)orig_emit;
16846                 if (PL_regkind[op] == POSIXD) {
16847                     if (op == POSIXL) {
16848                         RExC_contains_locale = 1;
16849                     }
16850                     if (invert) {
16851                         op += NPOSIXD - POSIXD;
16852                     }
16853                 }
16854             }
16855
16856             ret = reg_node(pRExC_state, op);
16857
16858             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
16859                 if (! SIZE_ONLY) {
16860                     FLAGS(ret) = arg;
16861                 }
16862                 *flagp |= HASWIDTH|SIMPLE;
16863             }
16864             else if (PL_regkind[op] == EXACT) {
16865                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
16866                                            TRUE /* downgradable to EXACT */
16867                                            );
16868             }
16869
16870             RExC_parse = (char *) cur_parse;
16871
16872             SvREFCNT_dec(posixes);
16873             SvREFCNT_dec(nposixes);
16874             SvREFCNT_dec(simple_posixes);
16875             SvREFCNT_dec(cp_list);
16876             SvREFCNT_dec(cp_foldable_list);
16877             return ret;
16878         }
16879     }
16880
16881     if (SIZE_ONLY)
16882         return ret;
16883     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
16884
16885     /* If folding, we calculate all characters that could fold to or from the
16886      * ones already on the list */
16887     if (cp_foldable_list) {
16888         if (FOLD) {
16889             UV start, end;      /* End points of code point ranges */
16890
16891             SV* fold_intersection = NULL;
16892             SV** use_list;
16893
16894             /* Our calculated list will be for Unicode rules.  For locale
16895              * matching, we have to keep a separate list that is consulted at
16896              * runtime only when the locale indicates Unicode rules.  For
16897              * non-locale, we just use the general list */
16898             if (LOC) {
16899                 use_list = &only_utf8_locale_list;
16900             }
16901             else {
16902                 use_list = &cp_list;
16903             }
16904
16905             /* Only the characters in this class that participate in folds need
16906              * be checked.  Get the intersection of this class and all the
16907              * possible characters that are foldable.  This can quickly narrow
16908              * down a large class */
16909             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
16910                                   &fold_intersection);
16911
16912             /* The folds for all the Latin1 characters are hard-coded into this
16913              * program, but we have to go out to disk to get the others. */
16914             if (invlist_highest(cp_foldable_list) >= 256) {
16915
16916                 /* This is a hash that for a particular fold gives all
16917                  * characters that are involved in it */
16918                 if (! PL_utf8_foldclosures) {
16919                     _load_PL_utf8_foldclosures();
16920                 }
16921             }
16922
16923             /* Now look at the foldable characters in this class individually */
16924             invlist_iterinit(fold_intersection);
16925             while (invlist_iternext(fold_intersection, &start, &end)) {
16926                 UV j;
16927
16928                 /* Look at every character in the range */
16929                 for (j = start; j <= end; j++) {
16930                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
16931                     STRLEN foldlen;
16932                     SV** listp;
16933
16934                     if (j < 256) {
16935
16936                         if (IS_IN_SOME_FOLD_L1(j)) {
16937
16938                             /* ASCII is always matched; non-ASCII is matched
16939                              * only under Unicode rules (which could happen
16940                              * under /l if the locale is a UTF-8 one */
16941                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
16942                                 *use_list = add_cp_to_invlist(*use_list,
16943                                                             PL_fold_latin1[j]);
16944                             }
16945                             else {
16946                                 has_upper_latin1_only_utf8_matches
16947                                     = add_cp_to_invlist(
16948                                             has_upper_latin1_only_utf8_matches,
16949                                             PL_fold_latin1[j]);
16950                             }
16951                         }
16952
16953                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
16954                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
16955                         {
16956                             add_above_Latin1_folds(pRExC_state,
16957                                                    (U8) j,
16958                                                    use_list);
16959                         }
16960                         continue;
16961                     }
16962
16963                     /* Here is an above Latin1 character.  We don't have the
16964                      * rules hard-coded for it.  First, get its fold.  This is
16965                      * the simple fold, as the multi-character folds have been
16966                      * handled earlier and separated out */
16967                     _to_uni_fold_flags(j, foldbuf, &foldlen,
16968                                                         (ASCII_FOLD_RESTRICTED)
16969                                                         ? FOLD_FLAGS_NOMIX_ASCII
16970                                                         : 0);
16971
16972                     /* Single character fold of above Latin1.  Add everything in
16973                     * its fold closure to the list that this node should match.
16974                     * The fold closures data structure is a hash with the keys
16975                     * being the UTF-8 of every character that is folded to, like
16976                     * 'k', and the values each an array of all code points that
16977                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
16978                     * Multi-character folds are not included */
16979                     if ((listp = hv_fetch(PL_utf8_foldclosures,
16980                                         (char *) foldbuf, foldlen, FALSE)))
16981                     {
16982                         AV* list = (AV*) *listp;
16983                         IV k;
16984                         for (k = 0; k <= av_tindex(list); k++) {
16985                             SV** c_p = av_fetch(list, k, FALSE);
16986                             UV c;
16987                             assert(c_p);
16988
16989                             c = SvUV(*c_p);
16990
16991                             /* /aa doesn't allow folds between ASCII and non- */
16992                             if ((ASCII_FOLD_RESTRICTED
16993                                 && (isASCII(c) != isASCII(j))))
16994                             {
16995                                 continue;
16996                             }
16997
16998                             /* Folds under /l which cross the 255/256 boundary
16999                              * are added to a separate list.  (These are valid
17000                              * only when the locale is UTF-8.) */
17001                             if (c < 256 && LOC) {
17002                                 *use_list = add_cp_to_invlist(*use_list, c);
17003                                 continue;
17004                             }
17005
17006                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17007                             {
17008                                 cp_list = add_cp_to_invlist(cp_list, c);
17009                             }
17010                             else {
17011                                 /* Similarly folds involving non-ascii Latin1
17012                                 * characters under /d are added to their list */
17013                                 has_upper_latin1_only_utf8_matches
17014                                         = add_cp_to_invlist(
17015                                            has_upper_latin1_only_utf8_matches,
17016                                            c);
17017                             }
17018                         }
17019                     }
17020                 }
17021             }
17022             SvREFCNT_dec_NN(fold_intersection);
17023         }
17024
17025         /* Now that we have finished adding all the folds, there is no reason
17026          * to keep the foldable list separate */
17027         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17028         SvREFCNT_dec_NN(cp_foldable_list);
17029     }
17030
17031     /* And combine the result (if any) with any inversion list from posix
17032      * classes.  The lists are kept separate up to now because we don't want to
17033      * fold the classes (folding of those is automatically handled by the swash
17034      * fetching code) */
17035     if (simple_posixes) {
17036         _invlist_union(cp_list, simple_posixes, &cp_list);
17037         SvREFCNT_dec_NN(simple_posixes);
17038     }
17039     if (posixes || nposixes) {
17040         if (posixes && AT_LEAST_ASCII_RESTRICTED) {
17041             /* Under /a and /aa, nothing above ASCII matches these */
17042             _invlist_intersection(posixes,
17043                                   PL_XPosix_ptrs[_CC_ASCII],
17044                                   &posixes);
17045         }
17046         if (nposixes) {
17047             if (DEPENDS_SEMANTICS) {
17048                 /* Under /d, everything in the upper half of the Latin1 range
17049                  * matches these complements */
17050                 ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17051             }
17052             else if (AT_LEAST_ASCII_RESTRICTED) {
17053                 /* Under /a and /aa, everything above ASCII matches these
17054                  * complements */
17055                 _invlist_union_complement_2nd(nposixes,
17056                                               PL_XPosix_ptrs[_CC_ASCII],
17057                                               &nposixes);
17058             }
17059             if (posixes) {
17060                 _invlist_union(posixes, nposixes, &posixes);
17061                 SvREFCNT_dec_NN(nposixes);
17062             }
17063             else {
17064                 posixes = nposixes;
17065             }
17066         }
17067         if (! DEPENDS_SEMANTICS) {
17068             if (cp_list) {
17069                 _invlist_union(cp_list, posixes, &cp_list);
17070                 SvREFCNT_dec_NN(posixes);
17071             }
17072             else {
17073                 cp_list = posixes;
17074             }
17075         }
17076         else {
17077             /* Under /d, we put into a separate list the Latin1 things that
17078              * match only when the target string is utf8 */
17079             SV* nonascii_but_latin1_properties = NULL;
17080             _invlist_intersection(posixes, PL_UpperLatin1,
17081                                   &nonascii_but_latin1_properties);
17082             _invlist_subtract(posixes, nonascii_but_latin1_properties,
17083                               &posixes);
17084             if (cp_list) {
17085                 _invlist_union(cp_list, posixes, &cp_list);
17086                 SvREFCNT_dec_NN(posixes);
17087             }
17088             else {
17089                 cp_list = posixes;
17090             }
17091
17092             if (has_upper_latin1_only_utf8_matches) {
17093                 _invlist_union(has_upper_latin1_only_utf8_matches,
17094                                nonascii_but_latin1_properties,
17095                                &has_upper_latin1_only_utf8_matches);
17096                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
17097             }
17098             else {
17099                 has_upper_latin1_only_utf8_matches
17100                                             = nonascii_but_latin1_properties;
17101             }
17102         }
17103     }
17104
17105     /* And combine the result (if any) with any inversion list from properties.
17106      * The lists are kept separate up to now so that we can distinguish the two
17107      * in regards to matching above-Unicode.  A run-time warning is generated
17108      * if a Unicode property is matched against a non-Unicode code point. But,
17109      * we allow user-defined properties to match anything, without any warning,
17110      * and we also suppress the warning if there is a portion of the character
17111      * class that isn't a Unicode property, and which matches above Unicode, \W
17112      * or [\x{110000}] for example.
17113      * (Note that in this case, unlike the Posix one above, there is no
17114      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
17115      * forces Unicode semantics */
17116     if (properties) {
17117         if (cp_list) {
17118
17119             /* If it matters to the final outcome, see if a non-property
17120              * component of the class matches above Unicode.  If so, the
17121              * warning gets suppressed.  This is true even if just a single
17122              * such code point is specified, as, though not strictly correct if
17123              * another such code point is matched against, the fact that they
17124              * are using above-Unicode code points indicates they should know
17125              * the issues involved */
17126             if (warn_super) {
17127                 warn_super = ! (invert
17128                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
17129             }
17130
17131             _invlist_union(properties, cp_list, &cp_list);
17132             SvREFCNT_dec_NN(properties);
17133         }
17134         else {
17135             cp_list = properties;
17136         }
17137
17138         if (warn_super) {
17139             ANYOF_FLAGS(ret)
17140              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17141
17142             /* Because an ANYOF node is the only one that warns, this node
17143              * can't be optimized into something else */
17144             optimizable = FALSE;
17145         }
17146     }
17147
17148     /* Here, we have calculated what code points should be in the character
17149      * class.
17150      *
17151      * Now we can see about various optimizations.  Fold calculation (which we
17152      * did above) needs to take place before inversion.  Otherwise /[^k]/i
17153      * would invert to include K, which under /i would match k, which it
17154      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
17155      * folded until runtime */
17156
17157     /* If we didn't do folding, it's because some information isn't available
17158      * until runtime; set the run-time fold flag for these.  (We don't have to
17159      * worry about properties folding, as that is taken care of by the swash
17160      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
17161      * locales, or the class matches at least one 0-255 range code point */
17162     if (LOC && FOLD) {
17163
17164         /* Some things on the list might be unconditionally included because of
17165          * other components.  Remove them, and clean up the list if it goes to
17166          * 0 elements */
17167         if (only_utf8_locale_list && cp_list) {
17168             _invlist_subtract(only_utf8_locale_list, cp_list,
17169                               &only_utf8_locale_list);
17170
17171             if (_invlist_len(only_utf8_locale_list) == 0) {
17172                 SvREFCNT_dec_NN(only_utf8_locale_list);
17173                 only_utf8_locale_list = NULL;
17174             }
17175         }
17176         if (only_utf8_locale_list) {
17177             ANYOF_FLAGS(ret)
17178                  |=  ANYOFL_FOLD
17179                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
17180         }
17181         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
17182             UV start, end;
17183             invlist_iterinit(cp_list);
17184             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
17185                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
17186             }
17187             invlist_iterfinish(cp_list);
17188         }
17189     }
17190
17191 #define MATCHES_ALL_NON_UTF8_NON_ASCII(ret)                                 \
17192     (   DEPENDS_SEMANTICS                                                   \
17193      && (ANYOF_FLAGS(ret)                                                   \
17194         & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
17195
17196     /* See if we can simplify things under /d */
17197     if (   has_upper_latin1_only_utf8_matches
17198         || MATCHES_ALL_NON_UTF8_NON_ASCII(ret))
17199     {
17200         /* But not if we are inverting, as that screws it up */
17201         if (! invert) {
17202             if (has_upper_latin1_only_utf8_matches) {
17203                 if (MATCHES_ALL_NON_UTF8_NON_ASCII(ret)) {
17204
17205                     /* Here, we have both the flag and inversion list.  Any
17206                      * character in 'has_upper_latin1_only_utf8_matches'
17207                      * matches when UTF-8 is in effect, but it also matches
17208                      * when UTF-8 is not in effect because of
17209                      * MATCHES_ALL_NON_UTF8_NON_ASCII.  Therefore it matches
17210                      * unconditionally, so can be added to the regular list,
17211                      * and 'has_upper_latin1_only_utf8_matches' cleared */
17212                     _invlist_union(cp_list,
17213                                    has_upper_latin1_only_utf8_matches,
17214                                    &cp_list);
17215                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17216                     has_upper_latin1_only_utf8_matches = NULL;
17217                 }
17218                 else if (cp_list) {
17219
17220                     /* Here, 'cp_list' gives chars that always match, and
17221                      * 'has_upper_latin1_only_utf8_matches' gives chars that
17222                      * were specified to match only if the target string is in
17223                      * UTF-8.  It may be that these overlap, so we can subtract
17224                      * the unconditionally matching from the conditional ones,
17225                      * to make the conditional list as small as possible,
17226                      * perhaps even clearing it, in which case more
17227                      * optimizations are possible later */
17228                     _invlist_subtract(has_upper_latin1_only_utf8_matches,
17229                                       cp_list,
17230                                       &has_upper_latin1_only_utf8_matches);
17231                     if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
17232                         SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17233                         has_upper_latin1_only_utf8_matches = NULL;
17234                     }
17235                 }
17236             }
17237
17238             /* Similarly, if the unconditional matches include every upper
17239              * latin1 character, we can clear that flag to permit later
17240              * optimizations */
17241             if (cp_list && MATCHES_ALL_NON_UTF8_NON_ASCII(ret)) {
17242                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
17243                 _invlist_subtract(only_non_utf8_list, cp_list,
17244                                   &only_non_utf8_list);
17245                 if (_invlist_len(only_non_utf8_list) == 0) {
17246                     ANYOF_FLAGS(ret) &= ~ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17247                 }
17248                 SvREFCNT_dec_NN(only_non_utf8_list);
17249                 only_non_utf8_list = NULL;;
17250             }
17251         }
17252
17253         /* If we haven't gotten rid of all conditional matching, we change the
17254          * regnode type to indicate that */
17255         if (   has_upper_latin1_only_utf8_matches
17256             || MATCHES_ALL_NON_UTF8_NON_ASCII(ret))
17257         {
17258             OP(ret) = ANYOFD;
17259             optimizable = FALSE;
17260         }
17261     }
17262 #undef MATCHES_ALL_NON_UTF8_NON_ASCII
17263
17264     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
17265      * at compile time.  Besides not inverting folded locale now, we can't
17266      * invert if there are things such as \w, which aren't known until runtime
17267      * */
17268     if (cp_list
17269         && invert
17270         && OP(ret) != ANYOFD
17271         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
17272         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17273     {
17274         _invlist_invert(cp_list);
17275
17276         /* Any swash can't be used as-is, because we've inverted things */
17277         if (swash) {
17278             SvREFCNT_dec_NN(swash);
17279             swash = NULL;
17280         }
17281
17282         /* Clear the invert flag since have just done it here */
17283         invert = FALSE;
17284     }
17285
17286     if (ret_invlist) {
17287         assert(cp_list);
17288
17289         *ret_invlist = cp_list;
17290         SvREFCNT_dec(swash);
17291
17292         /* Discard the generated node */
17293         if (SIZE_ONLY) {
17294             RExC_size = orig_size;
17295         }
17296         else {
17297             RExC_emit = orig_emit;
17298         }
17299         return orig_emit;
17300     }
17301
17302     /* Some character classes are equivalent to other nodes.  Such nodes take
17303      * up less room and generally fewer operations to execute than ANYOF nodes.
17304      * Above, we checked for and optimized into some such equivalents for
17305      * certain common classes that are easy to test.  Getting to this point in
17306      * the code means that the class didn't get optimized there.  Since this
17307      * code is only executed in Pass 2, it is too late to save space--it has
17308      * been allocated in Pass 1, and currently isn't given back.  But turning
17309      * things into an EXACTish node can allow the optimizer to join it to any
17310      * adjacent such nodes.  And if the class is equivalent to things like /./,
17311      * expensive run-time swashes can be avoided.  Now that we have more
17312      * complete information, we can find things necessarily missed by the
17313      * earlier code.  Another possible "optimization" that isn't done is that
17314      * something like [Ee] could be changed into an EXACTFU.  khw tried this
17315      * and found that the ANYOF is faster, including for code points not in the
17316      * bitmap.  This still might make sense to do, provided it got joined with
17317      * an adjacent node(s) to create a longer EXACTFU one.  This could be
17318      * accomplished by creating a pseudo ANYOF_EXACTFU node type that the join
17319      * routine would know is joinable.  If that didn't happen, the node type
17320      * could then be made a straight ANYOF */
17321
17322     if (optimizable && cp_list && ! invert) {
17323         UV start, end;
17324         U8 op = END;  /* The optimzation node-type */
17325         int posix_class = -1;   /* Illegal value */
17326         const char * cur_parse= RExC_parse;
17327
17328         invlist_iterinit(cp_list);
17329         if (! invlist_iternext(cp_list, &start, &end)) {
17330
17331             /* Here, the list is empty.  This happens, for example, when a
17332              * Unicode property that doesn't match anything is the only element
17333              * in the character class (perluniprops.pod notes such properties).
17334              * */
17335             op = OPFAIL;
17336             *flagp |= HASWIDTH|SIMPLE;
17337         }
17338         else if (start == end) {    /* The range is a single code point */
17339             if (! invlist_iternext(cp_list, &start, &end)
17340
17341                     /* Don't do this optimization if it would require changing
17342                      * the pattern to UTF-8 */
17343                 && (start < 256 || UTF))
17344             {
17345                 /* Here, the list contains a single code point.  Can optimize
17346                  * into an EXACTish node */
17347
17348                 value = start;
17349
17350                 if (! FOLD) {
17351                     op = (LOC)
17352                          ? EXACTL
17353                          : EXACT;
17354                 }
17355                 else if (LOC) {
17356
17357                     /* A locale node under folding with one code point can be
17358                      * an EXACTFL, as its fold won't be calculated until
17359                      * runtime */
17360                     op = EXACTFL;
17361                 }
17362                 else {
17363
17364                     /* Here, we are generally folding, but there is only one
17365                      * code point to match.  If we have to, we use an EXACT
17366                      * node, but it would be better for joining with adjacent
17367                      * nodes in the optimization pass if we used the same
17368                      * EXACTFish node that any such are likely to be.  We can
17369                      * do this iff the code point doesn't participate in any
17370                      * folds.  For example, an EXACTF of a colon is the same as
17371                      * an EXACT one, since nothing folds to or from a colon. */
17372                     if (value < 256) {
17373                         if (IS_IN_SOME_FOLD_L1(value)) {
17374                             op = EXACT;
17375                         }
17376                     }
17377                     else {
17378                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
17379                             op = EXACT;
17380                         }
17381                     }
17382
17383                     /* If we haven't found the node type, above, it means we
17384                      * can use the prevailing one */
17385                     if (op == END) {
17386                         op = compute_EXACTish(pRExC_state);
17387                     }
17388                 }
17389             }
17390         }   /* End of first range contains just a single code point */
17391         else if (start == 0) {
17392             if (end == UV_MAX) {
17393                 op = SANY;
17394                 *flagp |= HASWIDTH|SIMPLE;
17395                 MARK_NAUGHTY(1);
17396             }
17397             else if (end == '\n' - 1
17398                     && invlist_iternext(cp_list, &start, &end)
17399                     && start == '\n' + 1 && end == UV_MAX)
17400             {
17401                 op = REG_ANY;
17402                 *flagp |= HASWIDTH|SIMPLE;
17403                 MARK_NAUGHTY(1);
17404             }
17405         }
17406         invlist_iterfinish(cp_list);
17407
17408         if (op == END) {
17409             const UV cp_list_len = _invlist_len(cp_list);
17410             const UV* cp_list_array = invlist_array(cp_list);
17411
17412             /* Here, didn't find an optimization.  See if this matches any of
17413              * the POSIX classes.  These run slightly faster for above-Unicode
17414              * code points, so don't bother with POSIXA ones nor the 2 that
17415              * have no above-Unicode matches.  We can avoid these checks unless
17416              * the ANYOF matches at least as high as the lowest POSIX one
17417              * (which was manually found to be \v.  The actual code point may
17418              * increase in later Unicode releases, if a higher code point is
17419              * assigned to be \v, but this code will never break.  It would
17420              * just mean we could execute the checks for posix optimizations
17421              * unnecessarily) */
17422
17423             if (cp_list_array[cp_list_len-1] > 0x2029) {
17424                 for (posix_class = 0;
17425                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
17426                      posix_class++)
17427                 {
17428                     int try_inverted;
17429                     if (posix_class == _CC_ASCII || posix_class == _CC_CNTRL) {
17430                         continue;
17431                     }
17432                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
17433
17434                         /* Check if matches normal or inverted */
17435                         if (_invlistEQ(cp_list,
17436                                        PL_XPosix_ptrs[posix_class],
17437                                        try_inverted))
17438                         {
17439                             op = (try_inverted)
17440                                  ? NPOSIXU
17441                                  : POSIXU;
17442                             *flagp |= HASWIDTH|SIMPLE;
17443                             goto found_posix;
17444                         }
17445                     }
17446                 }
17447               found_posix: ;
17448             }
17449         }
17450
17451         if (op != END) {
17452             RExC_parse = (char *)orig_parse;
17453             RExC_emit = (regnode *)orig_emit;
17454
17455             if (regarglen[op]) {
17456                 ret = reganode(pRExC_state, op, 0);
17457             } else {
17458                 ret = reg_node(pRExC_state, op);
17459             }
17460
17461             RExC_parse = (char *)cur_parse;
17462
17463             if (PL_regkind[op] == EXACT) {
17464                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17465                                            TRUE /* downgradable to EXACT */
17466                                           );
17467             }
17468             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17469                 FLAGS(ret) = posix_class;
17470             }
17471
17472             SvREFCNT_dec_NN(cp_list);
17473             return ret;
17474         }
17475     }
17476
17477     /* Here, <cp_list> contains all the code points we can determine at
17478      * compile time that match under all conditions.  Go through it, and
17479      * for things that belong in the bitmap, put them there, and delete from
17480      * <cp_list>.  While we are at it, see if everything above 255 is in the
17481      * list, and if so, set a flag to speed up execution */
17482
17483     populate_ANYOF_from_invlist(ret, &cp_list);
17484
17485     if (invert) {
17486         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
17487     }
17488
17489     /* Here, the bitmap has been populated with all the Latin1 code points that
17490      * always match.  Can now add to the overall list those that match only
17491      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
17492      * */
17493     if (has_upper_latin1_only_utf8_matches) {
17494         if (cp_list) {
17495             _invlist_union(cp_list,
17496                            has_upper_latin1_only_utf8_matches,
17497                            &cp_list);
17498             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17499         }
17500         else {
17501             cp_list = has_upper_latin1_only_utf8_matches;
17502         }
17503         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17504     }
17505
17506     /* If there is a swash and more than one element, we can't use the swash in
17507      * the optimization below. */
17508     if (swash && element_count > 1) {
17509         SvREFCNT_dec_NN(swash);
17510         swash = NULL;
17511     }
17512
17513     /* Note that the optimization of using 'swash' if it is the only thing in
17514      * the class doesn't have us change swash at all, so it can include things
17515      * that are also in the bitmap; otherwise we have purposely deleted that
17516      * duplicate information */
17517     set_ANYOF_arg(pRExC_state, ret, cp_list,
17518                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17519                    ? listsv : NULL,
17520                   only_utf8_locale_list,
17521                   swash, has_user_defined_property);
17522
17523     *flagp |= HASWIDTH|SIMPLE;
17524
17525     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
17526         RExC_contains_locale = 1;
17527     }
17528
17529     return ret;
17530 }
17531
17532 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
17533
17534 STATIC void
17535 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
17536                 regnode* const node,
17537                 SV* const cp_list,
17538                 SV* const runtime_defns,
17539                 SV* const only_utf8_locale_list,
17540                 SV* const swash,
17541                 const bool has_user_defined_property)
17542 {
17543     /* Sets the arg field of an ANYOF-type node 'node', using information about
17544      * the node passed-in.  If there is nothing outside the node's bitmap, the
17545      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
17546      * the count returned by add_data(), having allocated and stored an array,
17547      * av, that that count references, as follows:
17548      *  av[0] stores the character class description in its textual form.
17549      *        This is used later (regexec.c:Perl_regclass_swash()) to
17550      *        initialize the appropriate swash, and is also useful for dumping
17551      *        the regnode.  This is set to &PL_sv_undef if the textual
17552      *        description is not needed at run-time (as happens if the other
17553      *        elements completely define the class)
17554      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
17555      *        computed from av[0].  But if no further computation need be done,
17556      *        the swash is stored here now (and av[0] is &PL_sv_undef).
17557      *  av[2] stores the inversion list of code points that match only if the
17558      *        current locale is UTF-8
17559      *  av[3] stores the cp_list inversion list for use in addition or instead
17560      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
17561      *        (Otherwise everything needed is already in av[0] and av[1])
17562      *  av[4] is set if any component of the class is from a user-defined
17563      *        property; used only if av[3] exists */
17564
17565     UV n;
17566
17567     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
17568
17569     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
17570         assert(! (ANYOF_FLAGS(node)
17571                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
17572         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
17573     }
17574     else {
17575         AV * const av = newAV();
17576         SV *rv;
17577
17578         av_store(av, 0, (runtime_defns)
17579                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
17580         if (swash) {
17581             assert(cp_list);
17582             av_store(av, 1, swash);
17583             SvREFCNT_dec_NN(cp_list);
17584         }
17585         else {
17586             av_store(av, 1, &PL_sv_undef);
17587             if (cp_list) {
17588                 av_store(av, 3, cp_list);
17589                 av_store(av, 4, newSVuv(has_user_defined_property));
17590             }
17591         }
17592
17593         if (only_utf8_locale_list) {
17594             av_store(av, 2, only_utf8_locale_list);
17595         }
17596         else {
17597             av_store(av, 2, &PL_sv_undef);
17598         }
17599
17600         rv = newRV_noinc(MUTABLE_SV(av));
17601         n = add_data(pRExC_state, STR_WITH_LEN("s"));
17602         RExC_rxi->data->data[n] = (void*)rv;
17603         ARG_SET(node, n);
17604     }
17605 }
17606
17607 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
17608 SV *
17609 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
17610                                         const regnode* node,
17611                                         bool doinit,
17612                                         SV** listsvp,
17613                                         SV** only_utf8_locale_ptr,
17614                                         SV** output_invlist)
17615
17616 {
17617     /* For internal core use only.
17618      * Returns the swash for the input 'node' in the regex 'prog'.
17619      * If <doinit> is 'true', will attempt to create the swash if not already
17620      *    done.
17621      * If <listsvp> is non-null, will return the printable contents of the
17622      *    swash.  This can be used to get debugging information even before the
17623      *    swash exists, by calling this function with 'doinit' set to false, in
17624      *    which case the components that will be used to eventually create the
17625      *    swash are returned  (in a printable form).
17626      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
17627      *    store an inversion list of code points that should match only if the
17628      *    execution-time locale is a UTF-8 one.
17629      * If <output_invlist> is not NULL, it is where this routine is to store an
17630      *    inversion list of the code points that would be instead returned in
17631      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
17632      *    when this parameter is used, is just the non-code point data that
17633      *    will go into creating the swash.  This currently should be just
17634      *    user-defined properties whose definitions were not known at compile
17635      *    time.  Using this parameter allows for easier manipulation of the
17636      *    swash's data by the caller.  It is illegal to call this function with
17637      *    this parameter set, but not <listsvp>
17638      *
17639      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
17640      * that, in spite of this function's name, the swash it returns may include
17641      * the bitmap data as well */
17642
17643     SV *sw  = NULL;
17644     SV *si  = NULL;         /* Input swash initialization string */
17645     SV* invlist = NULL;
17646
17647     RXi_GET_DECL(prog,progi);
17648     const struct reg_data * const data = prog ? progi->data : NULL;
17649
17650     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
17651     assert(! output_invlist || listsvp);
17652
17653     if (data && data->count) {
17654         const U32 n = ARG(node);
17655
17656         if (data->what[n] == 's') {
17657             SV * const rv = MUTABLE_SV(data->data[n]);
17658             AV * const av = MUTABLE_AV(SvRV(rv));
17659             SV **const ary = AvARRAY(av);
17660             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
17661
17662             si = *ary;  /* ary[0] = the string to initialize the swash with */
17663
17664             if (av_tindex(av) >= 2) {
17665                 if (only_utf8_locale_ptr
17666                     && ary[2]
17667                     && ary[2] != &PL_sv_undef)
17668                 {
17669                     *only_utf8_locale_ptr = ary[2];
17670                 }
17671                 else {
17672                     assert(only_utf8_locale_ptr);
17673                     *only_utf8_locale_ptr = NULL;
17674                 }
17675
17676                 /* Elements 3 and 4 are either both present or both absent. [3]
17677                  * is any inversion list generated at compile time; [4]
17678                  * indicates if that inversion list has any user-defined
17679                  * properties in it. */
17680                 if (av_tindex(av) >= 3) {
17681                     invlist = ary[3];
17682                     if (SvUV(ary[4])) {
17683                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
17684                     }
17685                 }
17686                 else {
17687                     invlist = NULL;
17688                 }
17689             }
17690
17691             /* Element [1] is reserved for the set-up swash.  If already there,
17692              * return it; if not, create it and store it there */
17693             if (ary[1] && SvROK(ary[1])) {
17694                 sw = ary[1];
17695             }
17696             else if (doinit && ((si && si != &PL_sv_undef)
17697                                  || (invlist && invlist != &PL_sv_undef))) {
17698                 assert(si);
17699                 sw = _core_swash_init("utf8", /* the utf8 package */
17700                                       "", /* nameless */
17701                                       si,
17702                                       1, /* binary */
17703                                       0, /* not from tr/// */
17704                                       invlist,
17705                                       &swash_init_flags);
17706                 (void)av_store(av, 1, sw);
17707             }
17708         }
17709     }
17710
17711     /* If requested, return a printable version of what this swash matches */
17712     if (listsvp) {
17713         SV* matches_string = NULL;
17714
17715         /* The swash should be used, if possible, to get the data, as it
17716          * contains the resolved data.  But this function can be called at
17717          * compile-time, before everything gets resolved, in which case we
17718          * return the currently best available information, which is the string
17719          * that will eventually be used to do that resolving, 'si' */
17720         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
17721             && (si && si != &PL_sv_undef))
17722         {
17723             /* Here, we only have 'si' (and possibly some passed-in data in
17724              * 'invlist', which is handled below)  If the caller only wants
17725              * 'si', use that.  */
17726             if (! output_invlist) {
17727                 matches_string = newSVsv(si);
17728             }
17729             else {
17730                 /* But if the caller wants an inversion list of the node, we
17731                  * need to parse 'si' and place as much as possible in the
17732                  * desired output inversion list, making 'matches_string' only
17733                  * contain the currently unresolvable things */
17734                 const char *si_string = SvPVX(si);
17735                 STRLEN remaining = SvCUR(si);
17736                 UV prev_cp = 0;
17737                 U8 count = 0;
17738
17739                 /* Ignore everything before the first new-line */
17740                 while (*si_string != '\n' && remaining > 0) {
17741                     si_string++;
17742                     remaining--;
17743                 }
17744                 assert(remaining > 0);
17745
17746                 si_string++;
17747                 remaining--;
17748
17749                 while (remaining > 0) {
17750
17751                     /* The data consists of just strings defining user-defined
17752                      * property names, but in prior incarnations, and perhaps
17753                      * somehow from pluggable regex engines, it could still
17754                      * hold hex code point definitions.  Each component of a
17755                      * range would be separated by a tab, and each range by a
17756                      * new-line.  If these are found, instead add them to the
17757                      * inversion list */
17758                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
17759                                      |PERL_SCAN_SILENT_NON_PORTABLE;
17760                     STRLEN len = remaining;
17761                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
17762
17763                     /* If the hex decode routine found something, it should go
17764                      * up to the next \n */
17765                     if (   *(si_string + len) == '\n') {
17766                         if (count) {    /* 2nd code point on line */
17767                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
17768                         }
17769                         else {
17770                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
17771                         }
17772                         count = 0;
17773                         goto prepare_for_next_iteration;
17774                     }
17775
17776                     /* If the hex decode was instead for the lower range limit,
17777                      * save it, and go parse the upper range limit */
17778                     if (*(si_string + len) == '\t') {
17779                         assert(count == 0);
17780
17781                         prev_cp = cp;
17782                         count = 1;
17783                       prepare_for_next_iteration:
17784                         si_string += len + 1;
17785                         remaining -= len + 1;
17786                         continue;
17787                     }
17788
17789                     /* Here, didn't find a legal hex number.  Just add it from
17790                      * here to the next \n */
17791
17792                     remaining -= len;
17793                     while (*(si_string + len) != '\n' && remaining > 0) {
17794                         remaining--;
17795                         len++;
17796                     }
17797                     if (*(si_string + len) == '\n') {
17798                         len++;
17799                         remaining--;
17800                     }
17801                     if (matches_string) {
17802                         sv_catpvn(matches_string, si_string, len - 1);
17803                     }
17804                     else {
17805                         matches_string = newSVpvn(si_string, len - 1);
17806                     }
17807                     si_string += len;
17808                     sv_catpvs(matches_string, " ");
17809                 } /* end of loop through the text */
17810
17811                 assert(matches_string);
17812                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
17813                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
17814                 }
17815             } /* end of has an 'si' but no swash */
17816         }
17817
17818         /* If we have a swash in place, its equivalent inversion list was above
17819          * placed into 'invlist'.  If not, this variable may contain a stored
17820          * inversion list which is information beyond what is in 'si' */
17821         if (invlist) {
17822
17823             /* Again, if the caller doesn't want the output inversion list, put
17824              * everything in 'matches-string' */
17825             if (! output_invlist) {
17826                 if ( ! matches_string) {
17827                     matches_string = newSVpvs("\n");
17828                 }
17829                 sv_catsv(matches_string, invlist_contents(invlist,
17830                                                   TRUE /* traditional style */
17831                                                   ));
17832             }
17833             else if (! *output_invlist) {
17834                 *output_invlist = invlist_clone(invlist);
17835             }
17836             else {
17837                 _invlist_union(*output_invlist, invlist, output_invlist);
17838             }
17839         }
17840
17841         *listsvp = matches_string;
17842     }
17843
17844     return sw;
17845 }
17846 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
17847
17848 /* reg_skipcomment()
17849
17850    Absorbs an /x style # comment from the input stream,
17851    returning a pointer to the first character beyond the comment, or if the
17852    comment terminates the pattern without anything following it, this returns
17853    one past the final character of the pattern (in other words, RExC_end) and
17854    sets the REG_RUN_ON_COMMENT_SEEN flag.
17855
17856    Note it's the callers responsibility to ensure that we are
17857    actually in /x mode
17858
17859 */
17860
17861 PERL_STATIC_INLINE char*
17862 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
17863 {
17864     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
17865
17866     assert(*p == '#');
17867
17868     while (p < RExC_end) {
17869         if (*(++p) == '\n') {
17870             return p+1;
17871         }
17872     }
17873
17874     /* we ran off the end of the pattern without ending the comment, so we have
17875      * to add an \n when wrapping */
17876     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
17877     return p;
17878 }
17879
17880 STATIC void
17881 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
17882                                 char ** p,
17883                                 const bool force_to_xmod
17884                          )
17885 {
17886     /* If the text at the current parse position '*p' is a '(?#...)' comment,
17887      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
17888      * is /x whitespace, advance '*p' so that on exit it points to the first
17889      * byte past all such white space and comments */
17890
17891     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
17892
17893     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
17894
17895     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
17896
17897     for (;;) {
17898         if (RExC_end - (*p) >= 3
17899             && *(*p)     == '('
17900             && *(*p + 1) == '?'
17901             && *(*p + 2) == '#')
17902         {
17903             while (*(*p) != ')') {
17904                 if ((*p) == RExC_end)
17905                     FAIL("Sequence (?#... not terminated");
17906                 (*p)++;
17907             }
17908             (*p)++;
17909             continue;
17910         }
17911
17912         if (use_xmod) {
17913             const char * save_p = *p;
17914             while ((*p) < RExC_end) {
17915                 STRLEN len;
17916                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
17917                     (*p) += len;
17918                 }
17919                 else if (*(*p) == '#') {
17920                     (*p) = reg_skipcomment(pRExC_state, (*p));
17921                 }
17922                 else {
17923                     break;
17924                 }
17925             }
17926             if (*p != save_p) {
17927                 continue;
17928             }
17929         }
17930
17931         break;
17932     }
17933
17934     return;
17935 }
17936
17937 /* nextchar()
17938
17939    Advances the parse position by one byte, unless that byte is the beginning
17940    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
17941    those two cases, the parse position is advanced beyond all such comments and
17942    white space.
17943
17944    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
17945 */
17946
17947 STATIC void
17948 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
17949 {
17950     PERL_ARGS_ASSERT_NEXTCHAR;
17951
17952     if (RExC_parse < RExC_end) {
17953         assert(   ! UTF
17954                || UTF8_IS_INVARIANT(*RExC_parse)
17955                || UTF8_IS_START(*RExC_parse));
17956
17957         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
17958
17959         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
17960                                 FALSE /* Don't assume /x */ );
17961     }
17962 }
17963
17964 STATIC regnode *
17965 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
17966 {
17967     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
17968      * space.  In pass1, it aligns and increments RExC_size; in pass2,
17969      * RExC_emit */
17970
17971     regnode * const ret = RExC_emit;
17972     GET_RE_DEBUG_FLAGS_DECL;
17973
17974     PERL_ARGS_ASSERT_REGNODE_GUTS;
17975
17976     assert(extra_size >= regarglen[op]);
17977
17978     if (SIZE_ONLY) {
17979         SIZE_ALIGN(RExC_size);
17980         RExC_size += 1 + extra_size;
17981         return(ret);
17982     }
17983     if (RExC_emit >= RExC_emit_bound)
17984         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
17985                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
17986
17987     NODE_ALIGN_FILL(ret);
17988 #ifndef RE_TRACK_PATTERN_OFFSETS
17989     PERL_UNUSED_ARG(name);
17990 #else
17991     if (RExC_offsets) {         /* MJD */
17992         MJD_OFFSET_DEBUG(
17993               ("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
17994               name, __LINE__,
17995               PL_reg_name[op],
17996               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
17997                 ? "Overwriting end of array!\n" : "OK",
17998               (UV)(RExC_emit - RExC_emit_start),
17999               (UV)(RExC_parse - RExC_start),
18000               (UV)RExC_offsets[0]));
18001         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
18002     }
18003 #endif
18004     return(ret);
18005 }
18006
18007 /*
18008 - reg_node - emit a node
18009 */
18010 STATIC regnode *                        /* Location. */
18011 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
18012 {
18013     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
18014
18015     PERL_ARGS_ASSERT_REG_NODE;
18016
18017     assert(regarglen[op] == 0);
18018
18019     if (PASS2) {
18020         regnode *ptr = ret;
18021         FILL_ADVANCE_NODE(ptr, op);
18022         RExC_emit = ptr;
18023     }
18024     return(ret);
18025 }
18026
18027 /*
18028 - reganode - emit a node with an argument
18029 */
18030 STATIC regnode *                        /* Location. */
18031 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
18032 {
18033     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
18034
18035     PERL_ARGS_ASSERT_REGANODE;
18036
18037     assert(regarglen[op] == 1);
18038
18039     if (PASS2) {
18040         regnode *ptr = ret;
18041         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
18042         RExC_emit = ptr;
18043     }
18044     return(ret);
18045 }
18046
18047 STATIC regnode *
18048 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
18049 {
18050     /* emit a node with U32 and I32 arguments */
18051
18052     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
18053
18054     PERL_ARGS_ASSERT_REG2LANODE;
18055
18056     assert(regarglen[op] == 2);
18057
18058     if (PASS2) {
18059         regnode *ptr = ret;
18060         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
18061         RExC_emit = ptr;
18062     }
18063     return(ret);
18064 }
18065
18066 /*
18067 - reginsert - insert an operator in front of already-emitted operand
18068 *
18069 * Means relocating the operand.
18070 */
18071 STATIC void
18072 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
18073 {
18074     regnode *src;
18075     regnode *dst;
18076     regnode *place;
18077     const int offset = regarglen[(U8)op];
18078     const int size = NODE_STEP_REGNODE + offset;
18079     GET_RE_DEBUG_FLAGS_DECL;
18080
18081     PERL_ARGS_ASSERT_REGINSERT;
18082     PERL_UNUSED_CONTEXT;
18083     PERL_UNUSED_ARG(depth);
18084 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
18085     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
18086     if (SIZE_ONLY) {
18087         RExC_size += size;
18088         return;
18089     }
18090
18091     src = RExC_emit;
18092     RExC_emit += size;
18093     dst = RExC_emit;
18094     if (RExC_open_parens) {
18095         int paren;
18096         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
18097         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
18098             if ( RExC_open_parens[paren] >= opnd ) {
18099                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
18100                 RExC_open_parens[paren] += size;
18101             } else {
18102                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
18103             }
18104             if ( RExC_close_parens[paren] >= opnd ) {
18105                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
18106                 RExC_close_parens[paren] += size;
18107             } else {
18108                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
18109             }
18110         }
18111     }
18112
18113     while (src > opnd) {
18114         StructCopy(--src, --dst, regnode);
18115 #ifdef RE_TRACK_PATTERN_OFFSETS
18116         if (RExC_offsets) {     /* MJD 20010112 */
18117             MJD_OFFSET_DEBUG(
18118                  ("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
18119                   "reg_insert",
18120                   __LINE__,
18121                   PL_reg_name[op],
18122                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
18123                     ? "Overwriting end of array!\n" : "OK",
18124                   (UV)(src - RExC_emit_start),
18125                   (UV)(dst - RExC_emit_start),
18126                   (UV)RExC_offsets[0]));
18127             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
18128             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
18129         }
18130 #endif
18131     }
18132
18133
18134     place = opnd;               /* Op node, where operand used to be. */
18135 #ifdef RE_TRACK_PATTERN_OFFSETS
18136     if (RExC_offsets) {         /* MJD */
18137         MJD_OFFSET_DEBUG(
18138               ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
18139               "reginsert",
18140               __LINE__,
18141               PL_reg_name[op],
18142               (UV)(place - RExC_emit_start) > RExC_offsets[0]
18143               ? "Overwriting end of array!\n" : "OK",
18144               (UV)(place - RExC_emit_start),
18145               (UV)(RExC_parse - RExC_start),
18146               (UV)RExC_offsets[0]));
18147         Set_Node_Offset(place, RExC_parse);
18148         Set_Node_Length(place, 1);
18149     }
18150 #endif
18151     src = NEXTOPER(place);
18152     FILL_ADVANCE_NODE(place, op);
18153     Zero(src, offset, regnode);
18154 }
18155
18156 /*
18157 - regtail - set the next-pointer at the end of a node chain of p to val.
18158 - SEE ALSO: regtail_study
18159 */
18160 STATIC void
18161 S_regtail(pTHX_ RExC_state_t * pRExC_state,
18162                 const regnode * const p,
18163                 const regnode * const val,
18164                 const U32 depth)
18165 {
18166     regnode *scan;
18167     GET_RE_DEBUG_FLAGS_DECL;
18168
18169     PERL_ARGS_ASSERT_REGTAIL;
18170 #ifndef DEBUGGING
18171     PERL_UNUSED_ARG(depth);
18172 #endif
18173
18174     if (SIZE_ONLY)
18175         return;
18176
18177     /* Find last node. */
18178     scan = (regnode *) p;
18179     for (;;) {
18180         regnode * const temp = regnext(scan);
18181         DEBUG_PARSE_r({
18182             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
18183             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18184             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
18185                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
18186                     (temp == NULL ? "->" : ""),
18187                     (temp == NULL ? PL_reg_name[OP(val)] : "")
18188             );
18189         });
18190         if (temp == NULL)
18191             break;
18192         scan = temp;
18193     }
18194
18195     if (reg_off_by_arg[OP(scan)]) {
18196         ARG_SET(scan, val - scan);
18197     }
18198     else {
18199         NEXT_OFF(scan) = val - scan;
18200     }
18201 }
18202
18203 #ifdef DEBUGGING
18204 /*
18205 - regtail_study - set the next-pointer at the end of a node chain of p to val.
18206 - Look for optimizable sequences at the same time.
18207 - currently only looks for EXACT chains.
18208
18209 This is experimental code. The idea is to use this routine to perform
18210 in place optimizations on branches and groups as they are constructed,
18211 with the long term intention of removing optimization from study_chunk so
18212 that it is purely analytical.
18213
18214 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
18215 to control which is which.
18216
18217 */
18218 /* TODO: All four parms should be const */
18219
18220 STATIC U8
18221 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
18222                       const regnode *val,U32 depth)
18223 {
18224     regnode *scan;
18225     U8 exact = PSEUDO;
18226 #ifdef EXPERIMENTAL_INPLACESCAN
18227     I32 min = 0;
18228 #endif
18229     GET_RE_DEBUG_FLAGS_DECL;
18230
18231     PERL_ARGS_ASSERT_REGTAIL_STUDY;
18232
18233
18234     if (SIZE_ONLY)
18235         return exact;
18236
18237     /* Find last node. */
18238
18239     scan = p;
18240     for (;;) {
18241         regnode * const temp = regnext(scan);
18242 #ifdef EXPERIMENTAL_INPLACESCAN
18243         if (PL_regkind[OP(scan)] == EXACT) {
18244             bool unfolded_multi_char;   /* Unexamined in this routine */
18245             if (join_exact(pRExC_state, scan, &min,
18246                            &unfolded_multi_char, 1, val, depth+1))
18247                 return EXACT;
18248         }
18249 #endif
18250         if ( exact ) {
18251             switch (OP(scan)) {
18252                 case EXACT:
18253                 case EXACTL:
18254                 case EXACTF:
18255                 case EXACTFA_NO_TRIE:
18256                 case EXACTFA:
18257                 case EXACTFU:
18258                 case EXACTFLU8:
18259                 case EXACTFU_SS:
18260                 case EXACTFL:
18261                         if( exact == PSEUDO )
18262                             exact= OP(scan);
18263                         else if ( exact != OP(scan) )
18264                             exact= 0;
18265                 case NOTHING:
18266                     break;
18267                 default:
18268                     exact= 0;
18269             }
18270         }
18271         DEBUG_PARSE_r({
18272             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
18273             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18274             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
18275                 SvPV_nolen_const(RExC_mysv),
18276                 REG_NODE_NUM(scan),
18277                 PL_reg_name[exact]);
18278         });
18279         if (temp == NULL)
18280             break;
18281         scan = temp;
18282     }
18283     DEBUG_PARSE_r({
18284         DEBUG_PARSE_MSG("");
18285         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
18286         PerlIO_printf(Perl_debug_log,
18287                       "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
18288                       SvPV_nolen_const(RExC_mysv),
18289                       (IV)REG_NODE_NUM(val),
18290                       (IV)(val - scan)
18291         );
18292     });
18293     if (reg_off_by_arg[OP(scan)]) {
18294         ARG_SET(scan, val - scan);
18295     }
18296     else {
18297         NEXT_OFF(scan) = val - scan;
18298     }
18299
18300     return exact;
18301 }
18302 #endif
18303
18304 /*
18305  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
18306  */
18307 #ifdef DEBUGGING
18308
18309 static void
18310 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
18311 {
18312     int bit;
18313     int set=0;
18314
18315     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18316
18317     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
18318         if (flags & (1<<bit)) {
18319             if (!set++ && lead)
18320                 PerlIO_printf(Perl_debug_log, "%s",lead);
18321             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_intflags_name[bit]);
18322         }
18323     }
18324     if (lead)  {
18325         if (set)
18326             PerlIO_printf(Perl_debug_log, "\n");
18327         else
18328             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
18329     }
18330 }
18331
18332 static void
18333 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
18334 {
18335     int bit;
18336     int set=0;
18337     regex_charset cs;
18338
18339     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18340
18341     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
18342         if (flags & (1<<bit)) {
18343             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
18344                 continue;
18345             }
18346             if (!set++ && lead)
18347                 PerlIO_printf(Perl_debug_log, "%s",lead);
18348             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
18349         }
18350     }
18351     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
18352             if (!set++ && lead) {
18353                 PerlIO_printf(Perl_debug_log, "%s",lead);
18354             }
18355             switch (cs) {
18356                 case REGEX_UNICODE_CHARSET:
18357                     PerlIO_printf(Perl_debug_log, "UNICODE");
18358                     break;
18359                 case REGEX_LOCALE_CHARSET:
18360                     PerlIO_printf(Perl_debug_log, "LOCALE");
18361                     break;
18362                 case REGEX_ASCII_RESTRICTED_CHARSET:
18363                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
18364                     break;
18365                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
18366                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
18367                     break;
18368                 default:
18369                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
18370                     break;
18371             }
18372     }
18373     if (lead)  {
18374         if (set)
18375             PerlIO_printf(Perl_debug_log, "\n");
18376         else
18377             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
18378     }
18379 }
18380 #endif
18381
18382 void
18383 Perl_regdump(pTHX_ const regexp *r)
18384 {
18385 #ifdef DEBUGGING
18386     SV * const sv = sv_newmortal();
18387     SV *dsv= sv_newmortal();
18388     RXi_GET_DECL(r,ri);
18389     GET_RE_DEBUG_FLAGS_DECL;
18390
18391     PERL_ARGS_ASSERT_REGDUMP;
18392
18393     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
18394
18395     /* Header fields of interest. */
18396     if (r->anchored_substr) {
18397         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
18398             RE_SV_DUMPLEN(r->anchored_substr), 30);
18399         PerlIO_printf(Perl_debug_log,
18400                       "anchored %s%s at %"IVdf" ",
18401                       s, RE_SV_TAIL(r->anchored_substr),
18402                       (IV)r->anchored_offset);
18403     } else if (r->anchored_utf8) {
18404         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
18405             RE_SV_DUMPLEN(r->anchored_utf8), 30);
18406         PerlIO_printf(Perl_debug_log,
18407                       "anchored utf8 %s%s at %"IVdf" ",
18408                       s, RE_SV_TAIL(r->anchored_utf8),
18409                       (IV)r->anchored_offset);
18410     }
18411     if (r->float_substr) {
18412         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
18413             RE_SV_DUMPLEN(r->float_substr), 30);
18414         PerlIO_printf(Perl_debug_log,
18415                       "floating %s%s at %"IVdf"..%"UVuf" ",
18416                       s, RE_SV_TAIL(r->float_substr),
18417                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18418     } else if (r->float_utf8) {
18419         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
18420             RE_SV_DUMPLEN(r->float_utf8), 30);
18421         PerlIO_printf(Perl_debug_log,
18422                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
18423                       s, RE_SV_TAIL(r->float_utf8),
18424                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18425     }
18426     if (r->check_substr || r->check_utf8)
18427         PerlIO_printf(Perl_debug_log,
18428                       (const char *)
18429                       (r->check_substr == r->float_substr
18430                        && r->check_utf8 == r->float_utf8
18431                        ? "(checking floating" : "(checking anchored"));
18432     if (r->intflags & PREGf_NOSCAN)
18433         PerlIO_printf(Perl_debug_log, " noscan");
18434     if (r->extflags & RXf_CHECK_ALL)
18435         PerlIO_printf(Perl_debug_log, " isall");
18436     if (r->check_substr || r->check_utf8)
18437         PerlIO_printf(Perl_debug_log, ") ");
18438
18439     if (ri->regstclass) {
18440         regprop(r, sv, ri->regstclass, NULL, NULL);
18441         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
18442     }
18443     if (r->intflags & PREGf_ANCH) {
18444         PerlIO_printf(Perl_debug_log, "anchored");
18445         if (r->intflags & PREGf_ANCH_MBOL)
18446             PerlIO_printf(Perl_debug_log, "(MBOL)");
18447         if (r->intflags & PREGf_ANCH_SBOL)
18448             PerlIO_printf(Perl_debug_log, "(SBOL)");
18449         if (r->intflags & PREGf_ANCH_GPOS)
18450             PerlIO_printf(Perl_debug_log, "(GPOS)");
18451         (void)PerlIO_putc(Perl_debug_log, ' ');
18452     }
18453     if (r->intflags & PREGf_GPOS_SEEN)
18454         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
18455     if (r->intflags & PREGf_SKIP)
18456         PerlIO_printf(Perl_debug_log, "plus ");
18457     if (r->intflags & PREGf_IMPLICIT)
18458         PerlIO_printf(Perl_debug_log, "implicit ");
18459     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
18460     if (r->extflags & RXf_EVAL_SEEN)
18461         PerlIO_printf(Perl_debug_log, "with eval ");
18462     PerlIO_printf(Perl_debug_log, "\n");
18463     DEBUG_FLAGS_r({
18464         regdump_extflags("r->extflags: ",r->extflags);
18465         regdump_intflags("r->intflags: ",r->intflags);
18466     });
18467 #else
18468     PERL_ARGS_ASSERT_REGDUMP;
18469     PERL_UNUSED_CONTEXT;
18470     PERL_UNUSED_ARG(r);
18471 #endif  /* DEBUGGING */
18472 }
18473
18474 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
18475 #ifdef DEBUGGING
18476
18477 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
18478      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
18479      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
18480      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
18481      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
18482      || _CC_VERTSPACE != 15
18483 #   error Need to adjust order of anyofs[]
18484 #  endif
18485 static const char * const anyofs[] = {
18486     "\\w",
18487     "\\W",
18488     "\\d",
18489     "\\D",
18490     "[:alpha:]",
18491     "[:^alpha:]",
18492     "[:lower:]",
18493     "[:^lower:]",
18494     "[:upper:]",
18495     "[:^upper:]",
18496     "[:punct:]",
18497     "[:^punct:]",
18498     "[:print:]",
18499     "[:^print:]",
18500     "[:alnum:]",
18501     "[:^alnum:]",
18502     "[:graph:]",
18503     "[:^graph:]",
18504     "[:cased:]",
18505     "[:^cased:]",
18506     "\\s",
18507     "\\S",
18508     "[:blank:]",
18509     "[:^blank:]",
18510     "[:xdigit:]",
18511     "[:^xdigit:]",
18512     "[:cntrl:]",
18513     "[:^cntrl:]",
18514     "[:ascii:]",
18515     "[:^ascii:]",
18516     "\\v",
18517     "\\V"
18518 };
18519 #endif
18520
18521 /*
18522 - regprop - printable representation of opcode, with run time support
18523 */
18524
18525 void
18526 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
18527 {
18528 #ifdef DEBUGGING
18529     int k;
18530     RXi_GET_DECL(prog,progi);
18531     GET_RE_DEBUG_FLAGS_DECL;
18532
18533     PERL_ARGS_ASSERT_REGPROP;
18534
18535     sv_setpvn(sv, "", 0);
18536
18537     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
18538         /* It would be nice to FAIL() here, but this may be called from
18539            regexec.c, and it would be hard to supply pRExC_state. */
18540         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
18541                                               (int)OP(o), (int)REGNODE_MAX);
18542     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
18543
18544     k = PL_regkind[OP(o)];
18545
18546     if (k == EXACT) {
18547         sv_catpvs(sv, " ");
18548         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
18549          * is a crude hack but it may be the best for now since
18550          * we have no flag "this EXACTish node was UTF-8"
18551          * --jhi */
18552         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
18553                   PERL_PV_ESCAPE_UNI_DETECT |
18554                   PERL_PV_ESCAPE_NONASCII   |
18555                   PERL_PV_PRETTY_ELLIPSES   |
18556                   PERL_PV_PRETTY_LTGT       |
18557                   PERL_PV_PRETTY_NOCLEAR
18558                   );
18559     } else if (k == TRIE) {
18560         /* print the details of the trie in dumpuntil instead, as
18561          * progi->data isn't available here */
18562         const char op = OP(o);
18563         const U32 n = ARG(o);
18564         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
18565                (reg_ac_data *)progi->data->data[n] :
18566                NULL;
18567         const reg_trie_data * const trie
18568             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
18569
18570         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
18571         DEBUG_TRIE_COMPILE_r(
18572           Perl_sv_catpvf(aTHX_ sv,
18573             "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
18574             (UV)trie->startstate,
18575             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
18576             (UV)trie->wordcount,
18577             (UV)trie->minlen,
18578             (UV)trie->maxlen,
18579             (UV)TRIE_CHARCOUNT(trie),
18580             (UV)trie->uniquecharcount
18581           );
18582         );
18583         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
18584             sv_catpvs(sv, "[");
18585             (void) put_charclass_bitmap_innards(sv,
18586                                                 ((IS_ANYOF_TRIE(op))
18587                                                  ? ANYOF_BITMAP(o)
18588                                                  : TRIE_BITMAP(trie)),
18589                                                 NULL,
18590                                                 NULL,
18591                                                 NULL
18592                                                );
18593             sv_catpvs(sv, "]");
18594         }
18595
18596     } else if (k == CURLY) {
18597         U32 lo = ARG1(o), hi = ARG2(o);
18598         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
18599             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
18600         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
18601         if (hi == REG_INFTY)
18602             sv_catpvs(sv, "INFTY");
18603         else
18604             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
18605         sv_catpvs(sv, "}");
18606     }
18607     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
18608         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
18609     else if (k == REF || k == OPEN || k == CLOSE
18610              || k == GROUPP || OP(o)==ACCEPT)
18611     {
18612         AV *name_list= NULL;
18613         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
18614         Perl_sv_catpvf(aTHX_ sv, "%"UVuf, (UV)parno);        /* Parenth number */
18615         if ( RXp_PAREN_NAMES(prog) ) {
18616             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
18617         } else if ( pRExC_state ) {
18618             name_list= RExC_paren_name_list;
18619         }
18620         if (name_list) {
18621             if ( k != REF || (OP(o) < NREF)) {
18622                 SV **name= av_fetch(name_list, parno, 0 );
18623                 if (name)
18624                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
18625             }
18626             else {
18627                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
18628                 I32 *nums=(I32*)SvPVX(sv_dat);
18629                 SV **name= av_fetch(name_list, nums[0], 0 );
18630                 I32 n;
18631                 if (name) {
18632                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
18633                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
18634                                     (n ? "," : ""), (IV)nums[n]);
18635                     }
18636                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
18637                 }
18638             }
18639         }
18640         if ( k == REF && reginfo) {
18641             U32 n = ARG(o);  /* which paren pair */
18642             I32 ln = prog->offs[n].start;
18643             if (prog->lastparen < n || ln == -1)
18644                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
18645             else if (ln == prog->offs[n].end)
18646                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
18647             else {
18648                 const char *s = reginfo->strbeg + ln;
18649                 Perl_sv_catpvf(aTHX_ sv, ": ");
18650                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
18651                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
18652             }
18653         }
18654     } else if (k == GOSUB) {
18655         AV *name_list= NULL;
18656         if ( RXp_PAREN_NAMES(prog) ) {
18657             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
18658         } else if ( pRExC_state ) {
18659             name_list= RExC_paren_name_list;
18660         }
18661
18662         /* Paren and offset */
18663         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o));
18664         if (name_list) {
18665             SV **name= av_fetch(name_list, ARG(o), 0 );
18666             if (name)
18667                 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
18668         }
18669     }
18670     else if (k == LOGICAL)
18671         /* 2: embedded, otherwise 1 */
18672         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
18673     else if (k == ANYOF) {
18674         const U8 flags = ANYOF_FLAGS(o);
18675         bool do_sep = FALSE;    /* Do we need to separate various components of
18676                                    the output? */
18677         /* Set if there is still an unresolved user-defined property */
18678         SV *unresolved                = NULL;
18679
18680         /* Things that are ignored except when the runtime locale is UTF-8 */
18681         SV *only_utf8_locale_invlist = NULL;
18682
18683         /* Code points that don't fit in the bitmap */
18684         SV *nonbitmap_invlist = NULL;
18685
18686         /* And things that aren't in the bitmap, but are small enough to be */
18687         SV* bitmap_range_not_in_bitmap = NULL;
18688
18689         if (OP(o) == ANYOFL) {
18690             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
18691                 sv_catpvs(sv, "{utf8-locale-reqd}");
18692             }
18693             if (flags & ANYOFL_FOLD) {
18694                 sv_catpvs(sv, "{i}");
18695             }
18696         }
18697
18698         /* If there is stuff outside the bitmap, get it */
18699         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
18700             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
18701                                                 &unresolved,
18702                                                 &only_utf8_locale_invlist,
18703                                                 &nonbitmap_invlist);
18704             /* The non-bitmap data may contain stuff that could fit in the
18705              * bitmap.  This could come from a user-defined property being
18706              * finally resolved when this call was done; or much more likely
18707              * because there are matches that require UTF-8 to be valid, and so
18708              * aren't in the bitmap.  This is teased apart later */
18709             _invlist_intersection(nonbitmap_invlist,
18710                                   PL_InBitmap,
18711                                   &bitmap_range_not_in_bitmap);
18712             /* Leave just the things that don't fit into the bitmap */
18713             _invlist_subtract(nonbitmap_invlist,
18714                               PL_InBitmap,
18715                               &nonbitmap_invlist);
18716         }
18717
18718         /* Obey this flag to add all above-the-bitmap code points */
18719         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
18720             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
18721                                                       NUM_ANYOF_CODE_POINTS,
18722                                                       UV_MAX);
18723         }
18724
18725         /* Ready to start outputting.  First, the initial left bracket */
18726         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
18727
18728         /* Then all the things that could fit in the bitmap */
18729         do_sep = put_charclass_bitmap_innards(sv,
18730                                               ANYOF_BITMAP(o),
18731                                               bitmap_range_not_in_bitmap,
18732                                               only_utf8_locale_invlist,
18733                                               o);
18734         SvREFCNT_dec(bitmap_range_not_in_bitmap);
18735
18736         /* If there are user-defined properties which haven't been defined yet,
18737          * output them, in a separate [] from the bitmap range stuff */
18738         if (unresolved) {
18739             if (do_sep) {
18740                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
18741             }
18742             if (flags & ANYOF_INVERT) {
18743                 sv_catpvs(sv, "^");
18744             }
18745             sv_catsv(sv, unresolved);
18746             do_sep = TRUE;
18747             SvREFCNT_dec_NN(unresolved);
18748         }
18749
18750         /* And, finally, add the above-the-bitmap stuff */
18751         if (nonbitmap_invlist) {
18752             SV* contents;
18753
18754             /* See if truncation size is overridden */
18755             const STRLEN dump_len = (PL_dump_re_max_len)
18756                                     ? PL_dump_re_max_len
18757                                     : 256;
18758
18759             /* This is output in a separate [] */
18760             if (do_sep) {
18761                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
18762             }
18763
18764             /* And, for easy of understanding, it is always output not-shown as
18765              * complemented */
18766             if (flags & ANYOF_INVERT) {
18767                 _invlist_invert(nonbitmap_invlist);
18768                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
18769             }
18770
18771             contents = invlist_contents(nonbitmap_invlist,
18772                                         FALSE /* output suitable for catsv */
18773                                        );
18774
18775             /* If the output is shorter than the permissible maximum, just do it. */
18776             if (SvCUR(contents) <= dump_len) {
18777                 sv_catsv(sv, contents);
18778             }
18779             else {
18780                 const char * contents_string = SvPVX(contents);
18781                 STRLEN i = dump_len;
18782
18783                 /* Otherwise, start at the permissible max and work back to the
18784                  * first break possibility */
18785                 while (i > 0 && contents_string[i] != ' ') {
18786                     i--;
18787                 }
18788                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
18789                                        find a legal break */
18790                     i = dump_len;
18791                 }
18792
18793                 sv_catpvn(sv, contents_string, i);
18794                 sv_catpvs(sv, "...");
18795             }
18796
18797             SvREFCNT_dec_NN(contents);
18798             SvREFCNT_dec_NN(nonbitmap_invlist);
18799         }
18800
18801         /* And finally the matching, closing ']' */
18802         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
18803     }
18804     else if (k == POSIXD || k == NPOSIXD) {
18805         U8 index = FLAGS(o) * 2;
18806         if (index < C_ARRAY_LENGTH(anyofs)) {
18807             if (*anyofs[index] != '[')  {
18808                 sv_catpv(sv, "[");
18809             }
18810             sv_catpv(sv, anyofs[index]);
18811             if (*anyofs[index] != '[')  {
18812                 sv_catpv(sv, "]");
18813             }
18814         }
18815         else {
18816             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
18817         }
18818     }
18819     else if (k == BOUND || k == NBOUND) {
18820         /* Must be synced with order of 'bound_type' in regcomp.h */
18821         const char * const bounds[] = {
18822             "",      /* Traditional */
18823             "{gcb}",
18824             "{lb}",
18825             "{sb}",
18826             "{wb}"
18827         };
18828         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
18829         sv_catpv(sv, bounds[FLAGS(o)]);
18830     }
18831     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
18832         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
18833     else if (OP(o) == SBOL)
18834         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
18835
18836     /* add on the verb argument if there is one */
18837     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
18838         Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
18839                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
18840     }
18841 #else
18842     PERL_UNUSED_CONTEXT;
18843     PERL_UNUSED_ARG(sv);
18844     PERL_UNUSED_ARG(o);
18845     PERL_UNUSED_ARG(prog);
18846     PERL_UNUSED_ARG(reginfo);
18847     PERL_UNUSED_ARG(pRExC_state);
18848 #endif  /* DEBUGGING */
18849 }
18850
18851
18852
18853 SV *
18854 Perl_re_intuit_string(pTHX_ REGEXP * const r)
18855 {                               /* Assume that RE_INTUIT is set */
18856     struct regexp *const prog = ReANY(r);
18857     GET_RE_DEBUG_FLAGS_DECL;
18858
18859     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
18860     PERL_UNUSED_CONTEXT;
18861
18862     DEBUG_COMPILE_r(
18863         {
18864             const char * const s = SvPV_nolen_const(RX_UTF8(r)
18865                       ? prog->check_utf8 : prog->check_substr);
18866
18867             if (!PL_colorset) reginitcolors();
18868             PerlIO_printf(Perl_debug_log,
18869                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
18870                       PL_colors[4],
18871                       RX_UTF8(r) ? "utf8 " : "",
18872                       PL_colors[5],PL_colors[0],
18873                       s,
18874                       PL_colors[1],
18875                       (strlen(s) > 60 ? "..." : ""));
18876         } );
18877
18878     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
18879     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
18880 }
18881
18882 /*
18883    pregfree()
18884
18885    handles refcounting and freeing the perl core regexp structure. When
18886    it is necessary to actually free the structure the first thing it
18887    does is call the 'free' method of the regexp_engine associated to
18888    the regexp, allowing the handling of the void *pprivate; member
18889    first. (This routine is not overridable by extensions, which is why
18890    the extensions free is called first.)
18891
18892    See regdupe and regdupe_internal if you change anything here.
18893 */
18894 #ifndef PERL_IN_XSUB_RE
18895 void
18896 Perl_pregfree(pTHX_ REGEXP *r)
18897 {
18898     SvREFCNT_dec(r);
18899 }
18900
18901 void
18902 Perl_pregfree2(pTHX_ REGEXP *rx)
18903 {
18904     struct regexp *const r = ReANY(rx);
18905     GET_RE_DEBUG_FLAGS_DECL;
18906
18907     PERL_ARGS_ASSERT_PREGFREE2;
18908
18909     if (r->mother_re) {
18910         ReREFCNT_dec(r->mother_re);
18911     } else {
18912         CALLREGFREE_PVT(rx); /* free the private data */
18913         SvREFCNT_dec(RXp_PAREN_NAMES(r));
18914         Safefree(r->xpv_len_u.xpvlenu_pv);
18915     }
18916     if (r->substrs) {
18917         SvREFCNT_dec(r->anchored_substr);
18918         SvREFCNT_dec(r->anchored_utf8);
18919         SvREFCNT_dec(r->float_substr);
18920         SvREFCNT_dec(r->float_utf8);
18921         Safefree(r->substrs);
18922     }
18923     RX_MATCH_COPY_FREE(rx);
18924 #ifdef PERL_ANY_COW
18925     SvREFCNT_dec(r->saved_copy);
18926 #endif
18927     Safefree(r->offs);
18928     SvREFCNT_dec(r->qr_anoncv);
18929     rx->sv_u.svu_rx = 0;
18930 }
18931
18932 /*  reg_temp_copy()
18933
18934     This is a hacky workaround to the structural issue of match results
18935     being stored in the regexp structure which is in turn stored in
18936     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
18937     could be PL_curpm in multiple contexts, and could require multiple
18938     result sets being associated with the pattern simultaneously, such
18939     as when doing a recursive match with (??{$qr})
18940
18941     The solution is to make a lightweight copy of the regexp structure
18942     when a qr// is returned from the code executed by (??{$qr}) this
18943     lightweight copy doesn't actually own any of its data except for
18944     the starp/end and the actual regexp structure itself.
18945
18946 */
18947
18948
18949 REGEXP *
18950 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
18951 {
18952     struct regexp *ret;
18953     struct regexp *const r = ReANY(rx);
18954     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
18955
18956     PERL_ARGS_ASSERT_REG_TEMP_COPY;
18957
18958     if (!ret_x)
18959         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
18960     else {
18961         SvOK_off((SV *)ret_x);
18962         if (islv) {
18963             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
18964                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
18965                made both spots point to the same regexp body.) */
18966             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
18967             assert(!SvPVX(ret_x));
18968             ret_x->sv_u.svu_rx = temp->sv_any;
18969             temp->sv_any = NULL;
18970             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
18971             SvREFCNT_dec_NN(temp);
18972             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
18973                ing below will not set it. */
18974             SvCUR_set(ret_x, SvCUR(rx));
18975         }
18976     }
18977     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
18978        sv_force_normal(sv) is called.  */
18979     SvFAKE_on(ret_x);
18980     ret = ReANY(ret_x);
18981
18982     SvFLAGS(ret_x) |= SvUTF8(rx);
18983     /* We share the same string buffer as the original regexp, on which we
18984        hold a reference count, incremented when mother_re is set below.
18985        The string pointer is copied here, being part of the regexp struct.
18986      */
18987     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
18988            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
18989     if (r->offs) {
18990         const I32 npar = r->nparens+1;
18991         Newx(ret->offs, npar, regexp_paren_pair);
18992         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
18993     }
18994     if (r->substrs) {
18995         Newx(ret->substrs, 1, struct reg_substr_data);
18996         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
18997
18998         SvREFCNT_inc_void(ret->anchored_substr);
18999         SvREFCNT_inc_void(ret->anchored_utf8);
19000         SvREFCNT_inc_void(ret->float_substr);
19001         SvREFCNT_inc_void(ret->float_utf8);
19002
19003         /* check_substr and check_utf8, if non-NULL, point to either their
19004            anchored or float namesakes, and don't hold a second reference.  */
19005     }
19006     RX_MATCH_COPIED_off(ret_x);
19007 #ifdef PERL_ANY_COW
19008     ret->saved_copy = NULL;
19009 #endif
19010     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
19011     SvREFCNT_inc_void(ret->qr_anoncv);
19012
19013     return ret_x;
19014 }
19015 #endif
19016
19017 /* regfree_internal()
19018
19019    Free the private data in a regexp. This is overloadable by
19020    extensions. Perl takes care of the regexp structure in pregfree(),
19021    this covers the *pprivate pointer which technically perl doesn't
19022    know about, however of course we have to handle the
19023    regexp_internal structure when no extension is in use.
19024
19025    Note this is called before freeing anything in the regexp
19026    structure.
19027  */
19028
19029 void
19030 Perl_regfree_internal(pTHX_ REGEXP * const rx)
19031 {
19032     struct regexp *const r = ReANY(rx);
19033     RXi_GET_DECL(r,ri);
19034     GET_RE_DEBUG_FLAGS_DECL;
19035
19036     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
19037
19038     DEBUG_COMPILE_r({
19039         if (!PL_colorset)
19040             reginitcolors();
19041         {
19042             SV *dsv= sv_newmortal();
19043             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
19044                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
19045             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
19046                 PL_colors[4],PL_colors[5],s);
19047         }
19048     });
19049 #ifdef RE_TRACK_PATTERN_OFFSETS
19050     if (ri->u.offsets)
19051         Safefree(ri->u.offsets);             /* 20010421 MJD */
19052 #endif
19053     if (ri->code_blocks) {
19054         int n;
19055         for (n = 0; n < ri->num_code_blocks; n++)
19056             SvREFCNT_dec(ri->code_blocks[n].src_regex);
19057         Safefree(ri->code_blocks);
19058     }
19059
19060     if (ri->data) {
19061         int n = ri->data->count;
19062
19063         while (--n >= 0) {
19064           /* If you add a ->what type here, update the comment in regcomp.h */
19065             switch (ri->data->what[n]) {
19066             case 'a':
19067             case 'r':
19068             case 's':
19069             case 'S':
19070             case 'u':
19071                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
19072                 break;
19073             case 'f':
19074                 Safefree(ri->data->data[n]);
19075                 break;
19076             case 'l':
19077             case 'L':
19078                 break;
19079             case 'T':
19080                 { /* Aho Corasick add-on structure for a trie node.
19081                      Used in stclass optimization only */
19082                     U32 refcount;
19083                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
19084 #ifdef USE_ITHREADS
19085                     dVAR;
19086 #endif
19087                     OP_REFCNT_LOCK;
19088                     refcount = --aho->refcount;
19089                     OP_REFCNT_UNLOCK;
19090                     if ( !refcount ) {
19091                         PerlMemShared_free(aho->states);
19092                         PerlMemShared_free(aho->fail);
19093                          /* do this last!!!! */
19094                         PerlMemShared_free(ri->data->data[n]);
19095                         /* we should only ever get called once, so
19096                          * assert as much, and also guard the free
19097                          * which /might/ happen twice. At the least
19098                          * it will make code anlyzers happy and it
19099                          * doesn't cost much. - Yves */
19100                         assert(ri->regstclass);
19101                         if (ri->regstclass) {
19102                             PerlMemShared_free(ri->regstclass);
19103                             ri->regstclass = 0;
19104                         }
19105                     }
19106                 }
19107                 break;
19108             case 't':
19109                 {
19110                     /* trie structure. */
19111                     U32 refcount;
19112                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
19113 #ifdef USE_ITHREADS
19114                     dVAR;
19115 #endif
19116                     OP_REFCNT_LOCK;
19117                     refcount = --trie->refcount;
19118                     OP_REFCNT_UNLOCK;
19119                     if ( !refcount ) {
19120                         PerlMemShared_free(trie->charmap);
19121                         PerlMemShared_free(trie->states);
19122                         PerlMemShared_free(trie->trans);
19123                         if (trie->bitmap)
19124                             PerlMemShared_free(trie->bitmap);
19125                         if (trie->jump)
19126                             PerlMemShared_free(trie->jump);
19127                         PerlMemShared_free(trie->wordinfo);
19128                         /* do this last!!!! */
19129                         PerlMemShared_free(ri->data->data[n]);
19130                     }
19131                 }
19132                 break;
19133             default:
19134                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
19135                                                     ri->data->what[n]);
19136             }
19137         }
19138         Safefree(ri->data->what);
19139         Safefree(ri->data);
19140     }
19141
19142     Safefree(ri);
19143 }
19144
19145 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
19146 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
19147 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
19148
19149 /*
19150    re_dup - duplicate a regexp.
19151
19152    This routine is expected to clone a given regexp structure. It is only
19153    compiled under USE_ITHREADS.
19154
19155    After all of the core data stored in struct regexp is duplicated
19156    the regexp_engine.dupe method is used to copy any private data
19157    stored in the *pprivate pointer. This allows extensions to handle
19158    any duplication it needs to do.
19159
19160    See pregfree() and regfree_internal() if you change anything here.
19161 */
19162 #if defined(USE_ITHREADS)
19163 #ifndef PERL_IN_XSUB_RE
19164 void
19165 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
19166 {
19167     dVAR;
19168     I32 npar;
19169     const struct regexp *r = ReANY(sstr);
19170     struct regexp *ret = ReANY(dstr);
19171
19172     PERL_ARGS_ASSERT_RE_DUP_GUTS;
19173
19174     npar = r->nparens+1;
19175     Newx(ret->offs, npar, regexp_paren_pair);
19176     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19177
19178     if (ret->substrs) {
19179         /* Do it this way to avoid reading from *r after the StructCopy().
19180            That way, if any of the sv_dup_inc()s dislodge *r from the L1
19181            cache, it doesn't matter.  */
19182         const bool anchored = r->check_substr
19183             ? r->check_substr == r->anchored_substr
19184             : r->check_utf8 == r->anchored_utf8;
19185         Newx(ret->substrs, 1, struct reg_substr_data);
19186         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19187
19188         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
19189         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
19190         ret->float_substr = sv_dup_inc(ret->float_substr, param);
19191         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
19192
19193         /* check_substr and check_utf8, if non-NULL, point to either their
19194            anchored or float namesakes, and don't hold a second reference.  */
19195
19196         if (ret->check_substr) {
19197             if (anchored) {
19198                 assert(r->check_utf8 == r->anchored_utf8);
19199                 ret->check_substr = ret->anchored_substr;
19200                 ret->check_utf8 = ret->anchored_utf8;
19201             } else {
19202                 assert(r->check_substr == r->float_substr);
19203                 assert(r->check_utf8 == r->float_utf8);
19204                 ret->check_substr = ret->float_substr;
19205                 ret->check_utf8 = ret->float_utf8;
19206             }
19207         } else if (ret->check_utf8) {
19208             if (anchored) {
19209                 ret->check_utf8 = ret->anchored_utf8;
19210             } else {
19211                 ret->check_utf8 = ret->float_utf8;
19212             }
19213         }
19214     }
19215
19216     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
19217     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
19218
19219     if (ret->pprivate)
19220         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
19221
19222     if (RX_MATCH_COPIED(dstr))
19223         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
19224     else
19225         ret->subbeg = NULL;
19226 #ifdef PERL_ANY_COW
19227     ret->saved_copy = NULL;
19228 #endif
19229
19230     /* Whether mother_re be set or no, we need to copy the string.  We
19231        cannot refrain from copying it when the storage points directly to
19232        our mother regexp, because that's
19233                1: a buffer in a different thread
19234                2: something we no longer hold a reference on
19235                so we need to copy it locally.  */
19236     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
19237     ret->mother_re   = NULL;
19238 }
19239 #endif /* PERL_IN_XSUB_RE */
19240
19241 /*
19242    regdupe_internal()
19243
19244    This is the internal complement to regdupe() which is used to copy
19245    the structure pointed to by the *pprivate pointer in the regexp.
19246    This is the core version of the extension overridable cloning hook.
19247    The regexp structure being duplicated will be copied by perl prior
19248    to this and will be provided as the regexp *r argument, however
19249    with the /old/ structures pprivate pointer value. Thus this routine
19250    may override any copying normally done by perl.
19251
19252    It returns a pointer to the new regexp_internal structure.
19253 */
19254
19255 void *
19256 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
19257 {
19258     dVAR;
19259     struct regexp *const r = ReANY(rx);
19260     regexp_internal *reti;
19261     int len;
19262     RXi_GET_DECL(r,ri);
19263
19264     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
19265
19266     len = ProgLen(ri);
19267
19268     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
19269           char, regexp_internal);
19270     Copy(ri->program, reti->program, len+1, regnode);
19271
19272     reti->num_code_blocks = ri->num_code_blocks;
19273     if (ri->code_blocks) {
19274         int n;
19275         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
19276                 struct reg_code_block);
19277         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
19278                 struct reg_code_block);
19279         for (n = 0; n < ri->num_code_blocks; n++)
19280              reti->code_blocks[n].src_regex = (REGEXP*)
19281                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
19282     }
19283     else
19284         reti->code_blocks = NULL;
19285
19286     reti->regstclass = NULL;
19287
19288     if (ri->data) {
19289         struct reg_data *d;
19290         const int count = ri->data->count;
19291         int i;
19292
19293         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
19294                 char, struct reg_data);
19295         Newx(d->what, count, U8);
19296
19297         d->count = count;
19298         for (i = 0; i < count; i++) {
19299             d->what[i] = ri->data->what[i];
19300             switch (d->what[i]) {
19301                 /* see also regcomp.h and regfree_internal() */
19302             case 'a': /* actually an AV, but the dup function is identical.  */
19303             case 'r':
19304             case 's':
19305             case 'S':
19306             case 'u': /* actually an HV, but the dup function is identical.  */
19307                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
19308                 break;
19309             case 'f':
19310                 /* This is cheating. */
19311                 Newx(d->data[i], 1, regnode_ssc);
19312                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
19313                 reti->regstclass = (regnode*)d->data[i];
19314                 break;
19315             case 'T':
19316                 /* Trie stclasses are readonly and can thus be shared
19317                  * without duplication. We free the stclass in pregfree
19318                  * when the corresponding reg_ac_data struct is freed.
19319                  */
19320                 reti->regstclass= ri->regstclass;
19321                 /* FALLTHROUGH */
19322             case 't':
19323                 OP_REFCNT_LOCK;
19324                 ((reg_trie_data*)ri->data->data[i])->refcount++;
19325                 OP_REFCNT_UNLOCK;
19326                 /* FALLTHROUGH */
19327             case 'l':
19328             case 'L':
19329                 d->data[i] = ri->data->data[i];
19330                 break;
19331             default:
19332                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'",
19333                                                            ri->data->what[i]);
19334             }
19335         }
19336
19337         reti->data = d;
19338     }
19339     else
19340         reti->data = NULL;
19341
19342     reti->name_list_idx = ri->name_list_idx;
19343
19344 #ifdef RE_TRACK_PATTERN_OFFSETS
19345     if (ri->u.offsets) {
19346         Newx(reti->u.offsets, 2*len+1, U32);
19347         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
19348     }
19349 #else
19350     SetProgLen(reti,len);
19351 #endif
19352
19353     return (void*)reti;
19354 }
19355
19356 #endif    /* USE_ITHREADS */
19357
19358 #ifndef PERL_IN_XSUB_RE
19359
19360 /*
19361  - regnext - dig the "next" pointer out of a node
19362  */
19363 regnode *
19364 Perl_regnext(pTHX_ regnode *p)
19365 {
19366     I32 offset;
19367
19368     if (!p)
19369         return(NULL);
19370
19371     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
19372         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19373                                                 (int)OP(p), (int)REGNODE_MAX);
19374     }
19375
19376     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
19377     if (offset == 0)
19378         return(NULL);
19379
19380     return(p+offset);
19381 }
19382 #endif
19383
19384 STATIC void
19385 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
19386 {
19387     va_list args;
19388     STRLEN l1 = strlen(pat1);
19389     STRLEN l2 = strlen(pat2);
19390     char buf[512];
19391     SV *msv;
19392     const char *message;
19393
19394     PERL_ARGS_ASSERT_RE_CROAK2;
19395
19396     if (l1 > 510)
19397         l1 = 510;
19398     if (l1 + l2 > 510)
19399         l2 = 510 - l1;
19400     Copy(pat1, buf, l1 , char);
19401     Copy(pat2, buf + l1, l2 , char);
19402     buf[l1 + l2] = '\n';
19403     buf[l1 + l2 + 1] = '\0';
19404     va_start(args, pat2);
19405     msv = vmess(buf, &args);
19406     va_end(args);
19407     message = SvPV_const(msv,l1);
19408     if (l1 > 512)
19409         l1 = 512;
19410     Copy(message, buf, l1 , char);
19411     /* l1-1 to avoid \n */
19412     Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf));
19413 }
19414
19415 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
19416
19417 #ifndef PERL_IN_XSUB_RE
19418 void
19419 Perl_save_re_context(pTHX)
19420 {
19421     I32 nparens = -1;
19422     I32 i;
19423
19424     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
19425
19426     if (PL_curpm) {
19427         const REGEXP * const rx = PM_GETRE(PL_curpm);
19428         if (rx)
19429             nparens = RX_NPARENS(rx);
19430     }
19431
19432     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
19433      * that PL_curpm will be null, but that utf8.pm and the modules it
19434      * loads will only use $1..$3.
19435      * The t/porting/re_context.t test file checks this assumption.
19436      */
19437     if (nparens == -1)
19438         nparens = 3;
19439
19440     for (i = 1; i <= nparens; i++) {
19441         char digits[TYPE_CHARS(long)];
19442         const STRLEN len = my_snprintf(digits, sizeof(digits),
19443                                        "%lu", (long)i);
19444         GV *const *const gvp
19445             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
19446
19447         if (gvp) {
19448             GV * const gv = *gvp;
19449             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
19450                 save_scalar(gv);
19451         }
19452     }
19453 }
19454 #endif
19455
19456 #ifdef DEBUGGING
19457
19458 STATIC void
19459 S_put_code_point(pTHX_ SV *sv, UV c)
19460 {
19461     PERL_ARGS_ASSERT_PUT_CODE_POINT;
19462
19463     if (c > 255) {
19464         Perl_sv_catpvf(aTHX_ sv, "\\x{%04"UVXf"}", c);
19465     }
19466     else if (isPRINT(c)) {
19467         const char string = (char) c;
19468
19469         /* We use {phrase} as metanotation in the class, so also escape literal
19470          * braces */
19471         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
19472             sv_catpvs(sv, "\\");
19473         sv_catpvn(sv, &string, 1);
19474     }
19475     else if (isMNEMONIC_CNTRL(c)) {
19476         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
19477     }
19478     else {
19479         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
19480     }
19481 }
19482
19483 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
19484
19485 STATIC void
19486 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
19487 {
19488     /* Appends to 'sv' a displayable version of the range of code points from
19489      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
19490      * that have them, when they occur at the beginning or end of the range.
19491      * It uses hex to output the remaining code points, unless 'allow_literals'
19492      * is true, in which case the printable ASCII ones are output as-is (though
19493      * some of these will be escaped by put_code_point()).
19494      *
19495      * NOTE:  This is designed only for printing ranges of code points that fit
19496      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
19497      */
19498
19499     const unsigned int min_range_count = 3;
19500
19501     assert(start <= end);
19502
19503     PERL_ARGS_ASSERT_PUT_RANGE;
19504
19505     while (start <= end) {
19506         UV this_end;
19507         const char * format;
19508
19509         if (end - start < min_range_count) {
19510
19511             /* Output chars individually when they occur in short ranges */
19512             for (; start <= end; start++) {
19513                 put_code_point(sv, start);
19514             }
19515             break;
19516         }
19517
19518         /* If permitted by the input options, and there is a possibility that
19519          * this range contains a printable literal, look to see if there is
19520          * one. */
19521         if (allow_literals && start <= MAX_PRINT_A) {
19522
19523             /* If the character at the beginning of the range isn't an ASCII
19524              * printable, effectively split the range into two parts:
19525              *  1) the portion before the first such printable,
19526              *  2) the rest
19527              * and output them separately. */
19528             if (! isPRINT_A(start)) {
19529                 UV temp_end = start + 1;
19530
19531                 /* There is no point looking beyond the final possible
19532                  * printable, in MAX_PRINT_A */
19533                 UV max = MIN(end, MAX_PRINT_A);
19534
19535                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
19536                     temp_end++;
19537                 }
19538
19539                 /* Here, temp_end points to one beyond the first printable if
19540                  * found, or to one beyond 'max' if not.  If none found, make
19541                  * sure that we use the entire range */
19542                 if (temp_end > MAX_PRINT_A) {
19543                     temp_end = end + 1;
19544                 }
19545
19546                 /* Output the first part of the split range: the part that
19547                  * doesn't have printables, with the parameter set to not look
19548                  * for literals (otherwise we would infinitely recurse) */
19549                 put_range(sv, start, temp_end - 1, FALSE);
19550
19551                 /* The 2nd part of the range (if any) starts here. */
19552                 start = temp_end;
19553
19554                 /* We do a continue, instead of dropping down, because even if
19555                  * the 2nd part is non-empty, it could be so short that we want
19556                  * to output it as individual characters, as tested for at the
19557                  * top of this loop.  */
19558                 continue;
19559             }
19560
19561             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
19562              * output a sub-range of just the digits or letters, then process
19563              * the remaining portion as usual. */
19564             if (isALPHANUMERIC_A(start)) {
19565                 UV mask = (isDIGIT_A(start))
19566                            ? _CC_DIGIT
19567                              : isUPPER_A(start)
19568                                ? _CC_UPPER
19569                                : _CC_LOWER;
19570                 UV temp_end = start + 1;
19571
19572                 /* Find the end of the sub-range that includes just the
19573                  * characters in the same class as the first character in it */
19574                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
19575                     temp_end++;
19576                 }
19577                 temp_end--;
19578
19579                 /* For short ranges, don't duplicate the code above to output
19580                  * them; just call recursively */
19581                 if (temp_end - start < min_range_count) {
19582                     put_range(sv, start, temp_end, FALSE);
19583                 }
19584                 else {  /* Output as a range */
19585                     put_code_point(sv, start);
19586                     sv_catpvs(sv, "-");
19587                     put_code_point(sv, temp_end);
19588                 }
19589                 start = temp_end + 1;
19590                 continue;
19591             }
19592
19593             /* We output any other printables as individual characters */
19594             if (isPUNCT_A(start) || isSPACE_A(start)) {
19595                 while (start <= end && (isPUNCT_A(start)
19596                                         || isSPACE_A(start)))
19597                 {
19598                     put_code_point(sv, start);
19599                     start++;
19600                 }
19601                 continue;
19602             }
19603         } /* End of looking for literals */
19604
19605         /* Here is not to output as a literal.  Some control characters have
19606          * mnemonic names.  Split off any of those at the beginning and end of
19607          * the range to print mnemonically.  It isn't possible for many of
19608          * these to be in a row, so this won't overwhelm with output */
19609         while (isMNEMONIC_CNTRL(start) && start <= end) {
19610             put_code_point(sv, start);
19611             start++;
19612         }
19613         if (start < end && isMNEMONIC_CNTRL(end)) {
19614
19615             /* Here, the final character in the range has a mnemonic name.
19616              * Work backwards from the end to find the final non-mnemonic */
19617             UV temp_end = end - 1;
19618             while (isMNEMONIC_CNTRL(temp_end)) {
19619                 temp_end--;
19620             }
19621
19622             /* And separately output the interior range that doesn't start or
19623              * end with mnemonics */
19624             put_range(sv, start, temp_end, FALSE);
19625
19626             /* Then output the mnemonic trailing controls */
19627             start = temp_end + 1;
19628             while (start <= end) {
19629                 put_code_point(sv, start);
19630                 start++;
19631             }
19632             break;
19633         }
19634
19635         /* As a final resort, output the range or subrange as hex. */
19636
19637         this_end = (end < NUM_ANYOF_CODE_POINTS)
19638                     ? end
19639                     : NUM_ANYOF_CODE_POINTS - 1;
19640 #if NUM_ANYOF_CODE_POINTS > 256
19641         format = (this_end < 256)
19642                  ? "\\x%02"UVXf"-\\x%02"UVXf""
19643                  : "\\x{%04"UVXf"}-\\x{%04"UVXf"}";
19644 #else
19645         format = "\\x%02"UVXf"-\\x%02"UVXf"";
19646 #endif
19647         GCC_DIAG_IGNORE(-Wformat-nonliteral);
19648         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
19649         GCC_DIAG_RESTORE;
19650         break;
19651     }
19652 }
19653
19654 STATIC void
19655 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
19656 {
19657     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
19658      * 'invlist' */
19659
19660     UV start, end;
19661     bool allow_literals = TRUE;
19662
19663     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
19664
19665     /* Generally, it is more readable if printable characters are output as
19666      * literals, but if a range (nearly) spans all of them, it's best to output
19667      * it as a single range.  This code will use a single range if all but 2
19668      * ASCII printables are in it */
19669     invlist_iterinit(invlist);
19670     while (invlist_iternext(invlist, &start, &end)) {
19671
19672         /* If the range starts beyond the final printable, it doesn't have any
19673          * in it */
19674         if (start > MAX_PRINT_A) {
19675             break;
19676         }
19677
19678         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
19679          * all but two, the range must start and end no later than 2 from
19680          * either end */
19681         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
19682             if (end > MAX_PRINT_A) {
19683                 end = MAX_PRINT_A;
19684             }
19685             if (start < ' ') {
19686                 start = ' ';
19687             }
19688             if (end - start >= MAX_PRINT_A - ' ' - 2) {
19689                 allow_literals = FALSE;
19690             }
19691             break;
19692         }
19693     }
19694     invlist_iterfinish(invlist);
19695
19696     /* Here we have figured things out.  Output each range */
19697     invlist_iterinit(invlist);
19698     while (invlist_iternext(invlist, &start, &end)) {
19699         if (start >= NUM_ANYOF_CODE_POINTS) {
19700             break;
19701         }
19702         put_range(sv, start, end, allow_literals);
19703     }
19704     invlist_iterfinish(invlist);
19705
19706     return;
19707 }
19708
19709 STATIC SV*
19710 S_put_charclass_bitmap_innards_common(pTHX_
19711         SV* invlist,            /* The bitmap */
19712         SV* posixes,            /* Under /l, things like [:word:], \S */
19713         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
19714         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
19715         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
19716         const bool invert       /* Is the result to be inverted? */
19717 )
19718 {
19719     /* Create and return an SV containing a displayable version of the bitmap
19720      * and associated information determined by the input parameters. */
19721
19722     SV * output;
19723
19724     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
19725
19726     if (invert) {
19727         output = newSVpvs("^");
19728     }
19729     else {
19730         output = newSVpvs("");
19731     }
19732
19733     /* First, the code points in the bitmap that are unconditionally there */
19734     put_charclass_bitmap_innards_invlist(output, invlist);
19735
19736     /* Traditionally, these have been placed after the main code points */
19737     if (posixes) {
19738         sv_catsv(output, posixes);
19739     }
19740
19741     if (only_utf8 && _invlist_len(only_utf8)) {
19742         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
19743         put_charclass_bitmap_innards_invlist(output, only_utf8);
19744     }
19745
19746     if (not_utf8 && _invlist_len(not_utf8)) {
19747         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
19748         put_charclass_bitmap_innards_invlist(output, not_utf8);
19749     }
19750
19751     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
19752         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
19753         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
19754
19755         /* This is the only list in this routine that can legally contain code
19756          * points outside the bitmap range.  The call just above to
19757          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
19758          * output them here.  There's about a half-dozen possible, and none in
19759          * contiguous ranges longer than 2 */
19760         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
19761             UV start, end;
19762             SV* above_bitmap = NULL;
19763
19764             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
19765
19766             invlist_iterinit(above_bitmap);
19767             while (invlist_iternext(above_bitmap, &start, &end)) {
19768                 UV i;
19769
19770                 for (i = start; i <= end; i++) {
19771                     put_code_point(output, i);
19772                 }
19773             }
19774             invlist_iterfinish(above_bitmap);
19775             SvREFCNT_dec_NN(above_bitmap);
19776         }
19777     }
19778
19779     /* If the only thing we output is the '^', clear it */
19780     if (invert && SvCUR(output) == 1) {
19781         SvCUR_set(output, 0);
19782     }
19783
19784     return output;
19785 }
19786
19787 STATIC bool
19788 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
19789                                      char *bitmap,
19790                                      SV *nonbitmap_invlist,
19791                                      SV *only_utf8_locale_invlist,
19792                                      const regnode * const node)
19793 {
19794     /* Appends to 'sv' a displayable version of the innards of the bracketed
19795      * character class defined by the other arguments:
19796      *  'bitmap' points to the bitmap.
19797      *  'nonbitmap_invlist' is an inversion list of the code points that are in
19798      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
19799      *      none.  The reasons for this could be that they require some
19800      *      condition such as the target string being or not being in UTF-8
19801      *      (under /d), or because they came from a user-defined property that
19802      *      was not resolved at the time of the regex compilation (under /u)
19803      *  'only_utf8_locale_invlist' is an inversion list of the code points that
19804      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
19805      *  'node' is the regex pattern node.  It is needed only when the above two
19806      *      parameters are not null, and is passed so that this routine can
19807      *      tease apart the various reasons for them.
19808      *
19809      * It returns TRUE if there was actually something output.  (It may be that
19810      * the bitmap, etc is empty.)
19811      *
19812      * When called for outputting the bitmap of a non-ANYOF node, just pass the
19813      * bitmap, with the succeeding parameters set to NULL.
19814      *
19815      */
19816
19817     /* In general, it tries to display the 'cleanest' representation of the
19818      * innards, choosing whether to display them inverted or not, regardless of
19819      * whether the class itself is to be inverted.  However,  there are some
19820      * cases where it can't try inverting, as what actually matches isn't known
19821      * until runtime, and hence the inversion isn't either. */
19822     bool inverting_allowed = TRUE;
19823
19824     int i;
19825     STRLEN orig_sv_cur = SvCUR(sv);
19826
19827     SV* invlist;            /* Inversion list we accumulate of code points that
19828                                are unconditionally matched */
19829     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
19830                                UTF-8 */
19831     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
19832                              */
19833     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
19834     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
19835                                        is UTF-8 */
19836
19837     SV* as_is_display;      /* The output string when we take the inputs
19838                               literally */
19839     SV* inverted_display;   /* The output string when we invert the inputs */
19840
19841     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
19842
19843     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
19844                                                    to match? */
19845     /* We are biased in favor of displaying things without them being inverted,
19846      * as that is generally easier to understand */
19847     const int bias = 5;
19848
19849     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
19850
19851     /* Start off with whatever code points are passed in.  (We clone, so we
19852      * don't change the caller's list) */
19853     if (nonbitmap_invlist) {
19854         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
19855         invlist = invlist_clone(nonbitmap_invlist);
19856     }
19857     else {  /* Worst case size is every other code point is matched */
19858         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
19859     }
19860
19861     if (flags) {
19862         if (OP(node) == ANYOFD) {
19863
19864             /* This flag indicates that the code points below 0x100 in the
19865              * nonbitmap list are precisely the ones that match only when the
19866              * target is UTF-8 (they should all be non-ASCII). */
19867             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
19868             {
19869                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
19870                 _invlist_subtract(invlist, only_utf8, &invlist);
19871             }
19872
19873             /* And this flag for matching all non-ASCII 0xFF and below */
19874             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
19875             {
19876                 if (invert) {
19877                     not_utf8 = _new_invlist(0);
19878                 }
19879                 else {
19880                     not_utf8 = invlist_clone(PL_UpperLatin1);
19881                 }
19882                 inverting_allowed = FALSE;  /* XXX needs more work to be able
19883                                                to allow this */
19884             }
19885         }
19886         else if (OP(node) == ANYOFL) {
19887
19888             /* If either of these flags are set, what matches isn't
19889              * determinable except during execution, so don't know enough here
19890              * to invert */
19891             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
19892                 inverting_allowed = FALSE;
19893             }
19894
19895             /* What the posix classes match also varies at runtime, so these
19896              * will be output symbolically. */
19897             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
19898                 int i;
19899
19900                 posixes = newSVpvs("");
19901                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
19902                     if (ANYOF_POSIXL_TEST(node,i)) {
19903                         sv_catpv(posixes, anyofs[i]);
19904                     }
19905                 }
19906             }
19907         }
19908     }
19909
19910     /* Accumulate the bit map into the unconditional match list */
19911     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
19912         if (BITMAP_TEST(bitmap, i)) {
19913             invlist = add_cp_to_invlist(invlist, i);
19914         }
19915     }
19916
19917     /* Make sure that the conditional match lists don't have anything in them
19918      * that match unconditionally; otherwise the output is quite confusing.
19919      * This could happen if the code that populates these misses some
19920      * duplication. */
19921     if (only_utf8) {
19922         _invlist_subtract(only_utf8, invlist, &only_utf8);
19923     }
19924     if (not_utf8) {
19925         _invlist_subtract(not_utf8, invlist, &not_utf8);
19926     }
19927
19928     if (only_utf8_locale_invlist) {
19929
19930         /* Since this list is passed in, we have to make a copy before
19931          * modifying it */
19932         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
19933
19934         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
19935
19936         /* And, it can get really weird for us to try outputting an inverted
19937          * form of this list when it has things above the bitmap, so don't even
19938          * try */
19939         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
19940             inverting_allowed = FALSE;
19941         }
19942     }
19943
19944     /* Calculate what the output would be if we take the input as-is */
19945     as_is_display = put_charclass_bitmap_innards_common(invlist,
19946                                                     posixes,
19947                                                     only_utf8,
19948                                                     not_utf8,
19949                                                     only_utf8_locale,
19950                                                     invert);
19951
19952     /* If have to take the output as-is, just do that */
19953     if (! inverting_allowed) {
19954         sv_catsv(sv, as_is_display);
19955     }
19956     else { /* But otherwise, create the output again on the inverted input, and
19957               use whichever version is shorter */
19958
19959         int inverted_bias, as_is_bias;
19960
19961         /* We will apply our bias to whichever of the the results doesn't have
19962          * the '^' */
19963         if (invert) {
19964             invert = FALSE;
19965             as_is_bias = bias;
19966             inverted_bias = 0;
19967         }
19968         else {
19969             invert = TRUE;
19970             as_is_bias = 0;
19971             inverted_bias = bias;
19972         }
19973
19974         /* Now invert each of the lists that contribute to the output,
19975          * excluding from the result things outside the possible range */
19976
19977         /* For the unconditional inversion list, we have to add in all the
19978          * conditional code points, so that when inverted, they will be gone
19979          * from it */
19980         _invlist_union(only_utf8, invlist, &invlist);
19981         _invlist_union(only_utf8_locale, invlist, &invlist);
19982         _invlist_invert(invlist);
19983         _invlist_intersection(invlist, PL_InBitmap, &invlist);
19984
19985         if (only_utf8) {
19986             _invlist_invert(only_utf8);
19987             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
19988         }
19989
19990         if (not_utf8) {
19991             _invlist_invert(not_utf8);
19992             _invlist_intersection(not_utf8, PL_UpperLatin1, &not_utf8);
19993         }
19994
19995         if (only_utf8_locale) {
19996             _invlist_invert(only_utf8_locale);
19997             _invlist_intersection(only_utf8_locale,
19998                                   PL_InBitmap,
19999                                   &only_utf8_locale);
20000         }
20001
20002         inverted_display = put_charclass_bitmap_innards_common(
20003                                             invlist,
20004                                             posixes,
20005                                             only_utf8,
20006                                             not_utf8,
20007                                             only_utf8_locale, invert);
20008
20009         /* Use the shortest representation, taking into account our bias
20010          * against showing it inverted */
20011         if (SvCUR(inverted_display) + inverted_bias
20012             < SvCUR(as_is_display) + as_is_bias)
20013         {
20014             sv_catsv(sv, inverted_display);
20015         }
20016         else {
20017             sv_catsv(sv, as_is_display);
20018         }
20019
20020         SvREFCNT_dec_NN(as_is_display);
20021         SvREFCNT_dec_NN(inverted_display);
20022     }
20023
20024     SvREFCNT_dec_NN(invlist);
20025     SvREFCNT_dec(only_utf8);
20026     SvREFCNT_dec(not_utf8);
20027     SvREFCNT_dec(posixes);
20028     SvREFCNT_dec(only_utf8_locale);
20029
20030     return SvCUR(sv) > orig_sv_cur;
20031 }
20032
20033 #define CLEAR_OPTSTART \
20034     if (optstart) STMT_START {                                               \
20035         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,                       \
20036                               " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
20037         optstart=NULL;                                                       \
20038     } STMT_END
20039
20040 #define DUMPUNTIL(b,e)                                                       \
20041                     CLEAR_OPTSTART;                                          \
20042                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
20043
20044 STATIC const regnode *
20045 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
20046             const regnode *last, const regnode *plast,
20047             SV* sv, I32 indent, U32 depth)
20048 {
20049     U8 op = PSEUDO;     /* Arbitrary non-END op. */
20050     const regnode *next;
20051     const regnode *optstart= NULL;
20052
20053     RXi_GET_DECL(r,ri);
20054     GET_RE_DEBUG_FLAGS_DECL;
20055
20056     PERL_ARGS_ASSERT_DUMPUNTIL;
20057
20058 #ifdef DEBUG_DUMPUNTIL
20059     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
20060         last ? last-start : 0,plast ? plast-start : 0);
20061 #endif
20062
20063     if (plast && plast < last)
20064         last= plast;
20065
20066     while (PL_regkind[op] != END && (!last || node < last)) {
20067         assert(node);
20068         /* While that wasn't END last time... */
20069         NODE_ALIGN(node);
20070         op = OP(node);
20071         if (op == CLOSE || op == WHILEM)
20072             indent--;
20073         next = regnext((regnode *)node);
20074
20075         /* Where, what. */
20076         if (OP(node) == OPTIMIZED) {
20077             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
20078                 optstart = node;
20079             else
20080                 goto after_print;
20081         } else
20082             CLEAR_OPTSTART;
20083
20084         regprop(r, sv, node, NULL, NULL);
20085         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
20086                       (int)(2*indent + 1), "", SvPVX_const(sv));
20087
20088         if (OP(node) != OPTIMIZED) {
20089             if (next == NULL)           /* Next ptr. */
20090                 PerlIO_printf(Perl_debug_log, " (0)");
20091             else if (PL_regkind[(U8)op] == BRANCH
20092                      && PL_regkind[OP(next)] != BRANCH )
20093                 PerlIO_printf(Perl_debug_log, " (FAIL)");
20094             else
20095                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
20096             (void)PerlIO_putc(Perl_debug_log, '\n');
20097         }
20098
20099       after_print:
20100         if (PL_regkind[(U8)op] == BRANCHJ) {
20101             assert(next);
20102             {
20103                 const regnode *nnode = (OP(next) == LONGJMP
20104                                        ? regnext((regnode *)next)
20105                                        : next);
20106                 if (last && nnode > last)
20107                     nnode = last;
20108                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
20109             }
20110         }
20111         else if (PL_regkind[(U8)op] == BRANCH) {
20112             assert(next);
20113             DUMPUNTIL(NEXTOPER(node), next);
20114         }
20115         else if ( PL_regkind[(U8)op]  == TRIE ) {
20116             const regnode *this_trie = node;
20117             const char op = OP(node);
20118             const U32 n = ARG(node);
20119             const reg_ac_data * const ac = op>=AHOCORASICK ?
20120                (reg_ac_data *)ri->data->data[n] :
20121                NULL;
20122             const reg_trie_data * const trie =
20123                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
20124 #ifdef DEBUGGING
20125             AV *const trie_words
20126                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
20127 #endif
20128             const regnode *nextbranch= NULL;
20129             I32 word_idx;
20130             sv_setpvs(sv, "");
20131             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
20132                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
20133
20134                 PerlIO_printf(Perl_debug_log, "%*s%s ",
20135                    (int)(2*(indent+3)), "",
20136                     elem_ptr
20137                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
20138                                 SvCUR(*elem_ptr), 60,
20139                                 PL_colors[0], PL_colors[1],
20140                                 (SvUTF8(*elem_ptr)
20141                                  ? PERL_PV_ESCAPE_UNI
20142                                  : 0)
20143                                 | PERL_PV_PRETTY_ELLIPSES
20144                                 | PERL_PV_PRETTY_LTGT
20145                             )
20146                     : "???"
20147                 );
20148                 if (trie->jump) {
20149                     U16 dist= trie->jump[word_idx+1];
20150                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
20151                                (UV)((dist ? this_trie + dist : next) - start));
20152                     if (dist) {
20153                         if (!nextbranch)
20154                             nextbranch= this_trie + trie->jump[0];
20155                         DUMPUNTIL(this_trie + dist, nextbranch);
20156                     }
20157                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
20158                         nextbranch= regnext((regnode *)nextbranch);
20159                 } else {
20160                     PerlIO_printf(Perl_debug_log, "\n");
20161                 }
20162             }
20163             if (last && next > last)
20164                 node= last;
20165             else
20166                 node= next;
20167         }
20168         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
20169             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
20170                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
20171         }
20172         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
20173             assert(next);
20174             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
20175         }
20176         else if ( op == PLUS || op == STAR) {
20177             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
20178         }
20179         else if (PL_regkind[(U8)op] == ANYOF) {
20180             /* arglen 1 + class block */
20181             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
20182                           ? ANYOF_POSIXL_SKIP
20183                           : ANYOF_SKIP);
20184             node = NEXTOPER(node);
20185         }
20186         else if (PL_regkind[(U8)op] == EXACT) {
20187             /* Literal string, where present. */
20188             node += NODE_SZ_STR(node) - 1;
20189             node = NEXTOPER(node);
20190         }
20191         else {
20192             node = NEXTOPER(node);
20193             node += regarglen[(U8)op];
20194         }
20195         if (op == CURLYX || op == OPEN)
20196             indent++;
20197     }
20198     CLEAR_OPTSTART;
20199 #ifdef DEBUG_DUMPUNTIL
20200     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
20201 #endif
20202     return node;
20203 }
20204
20205 #endif  /* DEBUGGING */
20206
20207 /*
20208  * ex: set ts=8 sts=4 sw=4 et:
20209  */