This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
corelist: updated for threads libraries
[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     *end_op;                /* 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 we have generated */
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_end_op     (pRExC_state->end_op)
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
506
507 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
508  * longest substring in the pattern. When it is not set the optimiser keeps
509  * track of position, but does not keep track of the actual strings seen,
510  *
511  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
512  * /foo/i will not.
513  *
514  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
515  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
516  * turned off because of the alternation (BRANCH). */
517 #define SCF_DO_SUBSTR           0x0400
518
519 #define SCF_DO_STCLASS_AND      0x0800
520 #define SCF_DO_STCLASS_OR       0x1000
521 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
522 #define SCF_WHILEM_VISITED_POS  0x2000
523
524 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
525 #define SCF_SEEN_ACCEPT         0x8000
526 #define SCF_TRIE_DOING_RESTUDY 0x10000
527 #define SCF_IN_DEFINE          0x20000
528
529
530
531
532 #define UTF cBOOL(RExC_utf8)
533
534 /* The enums for all these are ordered so things work out correctly */
535 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
536 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
537                                                      == REGEX_DEPENDS_CHARSET)
538 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
539 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
540                                                      >= REGEX_UNICODE_CHARSET)
541 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
542                                             == REGEX_ASCII_RESTRICTED_CHARSET)
543 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
544                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
545 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
546                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
547
548 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
549
550 /* For programs that want to be strictly Unicode compatible by dying if any
551  * attempt is made to match a non-Unicode code point against a Unicode
552  * property.  */
553 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
554
555 #define OOB_NAMEDCLASS          -1
556
557 /* There is no code point that is out-of-bounds, so this is problematic.  But
558  * its only current use is to initialize a variable that is always set before
559  * looked at. */
560 #define OOB_UNICODE             0xDEADBEEF
561
562 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
563 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
564
565
566 /* length of regex to show in messages that don't mark a position within */
567 #define RegexLengthToShowInErrorMessages 127
568
569 /*
570  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
571  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
572  * op/pragma/warn/regcomp.
573  */
574 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
575 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
576
577 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
578                         " in m/%"UTF8f MARKER2 "%"UTF8f"/"
579
580 /* The code in this file in places uses one level of recursion with parsing
581  * rebased to an alternate string constructed by us in memory.  This can take
582  * the form of something that is completely different from the input, or
583  * something that uses the input as part of the alternate.  In the first case,
584  * there should be no possibility of an error, as we are in complete control of
585  * the alternate string.  But in the second case we don't control the input
586  * portion, so there may be errors in that.  Here's an example:
587  *      /[abc\x{DF}def]/ui
588  * is handled specially because \x{df} folds to a sequence of more than one
589  * character, 'ss'.  What is done is to create and parse an alternate string,
590  * which looks like this:
591  *      /(?:\x{DF}|[abc\x{DF}def])/ui
592  * where it uses the input unchanged in the middle of something it constructs,
593  * which is a branch for the DF outside the character class, and clustering
594  * parens around the whole thing. (It knows enough to skip the DF inside the
595  * class while in this substitute parse.) 'abc' and 'def' may have errors that
596  * need to be reported.  The general situation looks like this:
597  *
598  *              sI                       tI               xI       eI
599  * Input:       ----------------------------------------------------
600  * Constructed:         ---------------------------------------------------
601  *                      sC               tC               xC       eC     EC
602  *
603  * The input string sI..eI is the input pattern.  The string sC..EC is the
604  * constructed substitute parse string.  The portions sC..tC and eC..EC are
605  * constructed by us.  The portion tC..eC is an exact duplicate of the input
606  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
607  * while parsing, we find an error at xC.  We want to display a message showing
608  * the real input string.  Thus we need to find the point xI in it which
609  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
610  * been constructed by us, and so shouldn't have errors.  We get:
611  *
612  *      xI = sI + (tI - sI) + (xC - tC)
613  *
614  * and, the offset into sI is:
615  *
616  *      (xI - sI) = (tI - sI) + (xC - tC)
617  *
618  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
619  * and we save tC as RExC_adjusted_start.
620  *
621  * During normal processing of the input pattern, everything points to that,
622  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
623  */
624
625 #define tI_sI           RExC_precomp_adj
626 #define tC              RExC_adjusted_start
627 #define sC              RExC_precomp
628 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
629 #define xI(xC)          (sC + xI_offset(xC))
630 #define eC              RExC_precomp_end
631
632 #define REPORT_LOCATION_ARGS(xC)                                            \
633     UTF8fARG(UTF,                                                           \
634              (xI(xC) > eC) /* Don't run off end */                          \
635               ? eC - sC   /* Length before the <--HERE */                   \
636               : xI_offset(xC),                                              \
637              sC),         /* The input pattern printed up to the <--HERE */ \
638     UTF8fARG(UTF,                                                           \
639              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
640              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
641
642 /* Used to point after bad bytes for an error message, but avoid skipping
643  * past a nul byte. */
644 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
645
646 /*
647  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
648  * arg. Show regex, up to a maximum length. If it's too long, chop and add
649  * "...".
650  */
651 #define _FAIL(code) STMT_START {                                        \
652     const char *ellipses = "";                                          \
653     IV len = RExC_precomp_end - RExC_precomp;                                   \
654                                                                         \
655     if (!SIZE_ONLY)                                                     \
656         SAVEFREESV(RExC_rx_sv);                                         \
657     if (len > RegexLengthToShowInErrorMessages) {                       \
658         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
659         len = RegexLengthToShowInErrorMessages - 10;                    \
660         ellipses = "...";                                               \
661     }                                                                   \
662     code;                                                               \
663 } STMT_END
664
665 #define FAIL(msg) _FAIL(                            \
666     Perl_croak(aTHX_ "%s in regex m/%"UTF8f"%s/",           \
667             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
668
669 #define FAIL2(msg,arg) _FAIL(                       \
670     Perl_croak(aTHX_ msg " in regex m/%"UTF8f"%s/",         \
671             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
672
673 /*
674  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
675  */
676 #define Simple_vFAIL(m) STMT_START {                                    \
677     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
678             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
679 } STMT_END
680
681 /*
682  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
683  */
684 #define vFAIL(m) STMT_START {                           \
685     if (!SIZE_ONLY)                                     \
686         SAVEFREESV(RExC_rx_sv);                         \
687     Simple_vFAIL(m);                                    \
688 } STMT_END
689
690 /*
691  * Like Simple_vFAIL(), but accepts two arguments.
692  */
693 #define Simple_vFAIL2(m,a1) STMT_START {                        \
694     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
695                       REPORT_LOCATION_ARGS(RExC_parse));        \
696 } STMT_END
697
698 /*
699  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
700  */
701 #define vFAIL2(m,a1) STMT_START {                       \
702     if (!SIZE_ONLY)                                     \
703         SAVEFREESV(RExC_rx_sv);                         \
704     Simple_vFAIL2(m, a1);                               \
705 } STMT_END
706
707
708 /*
709  * Like Simple_vFAIL(), but accepts three arguments.
710  */
711 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
712     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
713             REPORT_LOCATION_ARGS(RExC_parse));                  \
714 } STMT_END
715
716 /*
717  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
718  */
719 #define vFAIL3(m,a1,a2) STMT_START {                    \
720     if (!SIZE_ONLY)                                     \
721         SAVEFREESV(RExC_rx_sv);                         \
722     Simple_vFAIL3(m, a1, a2);                           \
723 } STMT_END
724
725 /*
726  * Like Simple_vFAIL(), but accepts four arguments.
727  */
728 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
729     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
730             REPORT_LOCATION_ARGS(RExC_parse));                  \
731 } STMT_END
732
733 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
734     if (!SIZE_ONLY)                                     \
735         SAVEFREESV(RExC_rx_sv);                         \
736     Simple_vFAIL4(m, a1, a2, a3);                       \
737 } STMT_END
738
739 /* A specialized version of vFAIL2 that works with UTF8f */
740 #define vFAIL2utf8f(m, a1) STMT_START {             \
741     if (!SIZE_ONLY)                                 \
742         SAVEFREESV(RExC_rx_sv);                     \
743     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
744             REPORT_LOCATION_ARGS(RExC_parse));      \
745 } STMT_END
746
747 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
748     if (!SIZE_ONLY)                                     \
749         SAVEFREESV(RExC_rx_sv);                         \
750     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
751             REPORT_LOCATION_ARGS(RExC_parse));          \
752 } STMT_END
753
754 /* These have asserts in them because of [perl #122671] Many warnings in
755  * regcomp.c can occur twice.  If they get output in pass1 and later in that
756  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
757  * would get output again.  So they should be output in pass2, and these
758  * asserts make sure new warnings follow that paradigm. */
759
760 /* m is not necessarily a "literal string", in this macro */
761 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
762     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
763                                        "%s" REPORT_LOCATION,            \
764                                   m, REPORT_LOCATION_ARGS(loc));        \
765 } STMT_END
766
767 #define ckWARNreg(loc,m) STMT_START {                                   \
768     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
769                                           m REPORT_LOCATION,            \
770                                           REPORT_LOCATION_ARGS(loc));   \
771 } STMT_END
772
773 #define vWARN(loc, m) STMT_START {                                      \
774     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
775                                        m REPORT_LOCATION,               \
776                                        REPORT_LOCATION_ARGS(loc));      \
777 } STMT_END
778
779 #define vWARN_dep(loc, m) STMT_START {                                  \
780     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
781                                        m REPORT_LOCATION,               \
782                                        REPORT_LOCATION_ARGS(loc));      \
783 } STMT_END
784
785 #define ckWARNdep(loc,m) STMT_START {                                   \
786     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
787                                             m REPORT_LOCATION,          \
788                                             REPORT_LOCATION_ARGS(loc)); \
789 } STMT_END
790
791 #define ckWARNregdep(loc,m) STMT_START {                                    \
792     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
793                                                       WARN_REGEXP),         \
794                                              m REPORT_LOCATION,             \
795                                              REPORT_LOCATION_ARGS(loc));    \
796 } STMT_END
797
798 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
799     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
800                                             m REPORT_LOCATION,              \
801                                             a1, REPORT_LOCATION_ARGS(loc)); \
802 } STMT_END
803
804 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
805     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
806                                           m REPORT_LOCATION,                \
807                                           a1, REPORT_LOCATION_ARGS(loc));   \
808 } STMT_END
809
810 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
811     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
812                                        m REPORT_LOCATION,                   \
813                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
814 } STMT_END
815
816 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
817     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
818                                           m REPORT_LOCATION,                \
819                                           a1, a2,                           \
820                                           REPORT_LOCATION_ARGS(loc));       \
821 } STMT_END
822
823 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
824     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
825                                        m REPORT_LOCATION,               \
826                                        a1, a2, a3,                      \
827                                        REPORT_LOCATION_ARGS(loc));      \
828 } STMT_END
829
830 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
831     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
832                                           m REPORT_LOCATION,            \
833                                           a1, a2, a3,                   \
834                                           REPORT_LOCATION_ARGS(loc));   \
835 } STMT_END
836
837 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
838     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
839                                        m REPORT_LOCATION,               \
840                                        a1, a2, a3, a4,                  \
841                                        REPORT_LOCATION_ARGS(loc));      \
842 } STMT_END
843
844 /* Macros for recording node offsets.   20001227 mjd@plover.com
845  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
846  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
847  * Element 0 holds the number n.
848  * Position is 1 indexed.
849  */
850 #ifndef RE_TRACK_PATTERN_OFFSETS
851 #define Set_Node_Offset_To_R(node,byte)
852 #define Set_Node_Offset(node,byte)
853 #define Set_Cur_Node_Offset
854 #define Set_Node_Length_To_R(node,len)
855 #define Set_Node_Length(node,len)
856 #define Set_Node_Cur_Length(node,start)
857 #define Node_Offset(n)
858 #define Node_Length(n)
859 #define Set_Node_Offset_Length(node,offset,len)
860 #define ProgLen(ri) ri->u.proglen
861 #define SetProgLen(ri,x) ri->u.proglen = x
862 #else
863 #define ProgLen(ri) ri->u.offsets[0]
864 #define SetProgLen(ri,x) ri->u.offsets[0] = x
865 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
866     if (! SIZE_ONLY) {                                                  \
867         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
868                     __LINE__, (int)(node), (int)(byte)));               \
869         if((node) < 0) {                                                \
870             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
871                                          (int)(node));                  \
872         } else {                                                        \
873             RExC_offsets[2*(node)-1] = (byte);                          \
874         }                                                               \
875     }                                                                   \
876 } STMT_END
877
878 #define Set_Node_Offset(node,byte) \
879     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
880 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
881
882 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
883     if (! SIZE_ONLY) {                                                  \
884         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
885                 __LINE__, (int)(node), (int)(len)));                    \
886         if((node) < 0) {                                                \
887             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
888                                          (int)(node));                  \
889         } else {                                                        \
890             RExC_offsets[2*(node)] = (len);                             \
891         }                                                               \
892     }                                                                   \
893 } STMT_END
894
895 #define Set_Node_Length(node,len) \
896     Set_Node_Length_To_R((node)-RExC_emit_start, len)
897 #define Set_Node_Cur_Length(node, start)                \
898     Set_Node_Length(node, RExC_parse - start)
899
900 /* Get offsets and lengths */
901 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
902 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
903
904 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
905     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
906     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
907 } STMT_END
908 #endif
909
910 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
911 #define EXPERIMENTAL_INPLACESCAN
912 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
913
914 #ifdef DEBUGGING
915 int
916 Perl_re_printf(pTHX_ const char *fmt, ...)
917 {
918     va_list ap;
919     int result;
920     PerlIO *f= Perl_debug_log;
921     PERL_ARGS_ASSERT_RE_PRINTF;
922     va_start(ap, fmt);
923     result = PerlIO_vprintf(f, fmt, ap);
924     va_end(ap);
925     return result;
926 }
927
928 int
929 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
930 {
931     va_list ap;
932     int result;
933     PerlIO *f= Perl_debug_log;
934     PERL_ARGS_ASSERT_RE_INDENTF;
935     va_start(ap, depth);
936     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
937     result = PerlIO_vprintf(f, fmt, ap);
938     va_end(ap);
939     return result;
940 }
941 #endif /* DEBUGGING */
942
943 #define DEBUG_RExC_seen()                                                   \
944         DEBUG_OPTIMISE_MORE_r({                                             \
945             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
946                                                                             \
947             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
948                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
949                                                                             \
950             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
951                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
952                                                                             \
953             if (RExC_seen & REG_GPOS_SEEN)                                  \
954                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
955                                                                             \
956             if (RExC_seen & REG_RECURSE_SEEN)                               \
957                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
958                                                                             \
959             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
960                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
961                                                                             \
962             if (RExC_seen & REG_VERBARG_SEEN)                               \
963                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
964                                                                             \
965             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
966                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
967                                                                             \
968             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
969                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
970                                                                             \
971             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
972                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
973                                                                             \
974             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
975                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
976                                                                             \
977             Perl_re_printf( aTHX_ "\n");                                                \
978         });
979
980 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
981   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
982
983 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
984     if ( ( flags ) ) {                                                      \
985         Perl_re_printf( aTHX_  "%s", open_str);                                         \
986         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
987         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
988         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
989         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
990         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
991         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
992         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
993         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
994         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
995         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
996         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
997         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
998         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
999         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
1000         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
1001         Perl_re_printf( aTHX_  "%s", close_str);                                        \
1002     }
1003
1004
1005 #define DEBUG_STUDYDATA(str,data,depth)                              \
1006 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
1007     Perl_re_indentf( aTHX_  "" str "Pos:%"IVdf"/%"IVdf                           \
1008         " Flags: 0x%"UVXf,                                           \
1009         depth,                                                       \
1010         (IV)((data)->pos_min),                                       \
1011         (IV)((data)->pos_delta),                                     \
1012         (UV)((data)->flags)                                          \
1013     );                                                               \
1014     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
1015     Perl_re_printf( aTHX_                                                        \
1016         " Whilem_c: %"IVdf" Lcp: %"IVdf" %s",                        \
1017         (IV)((data)->whilem_c),                                      \
1018         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
1019         is_inf ? "INF " : ""                                         \
1020     );                                                               \
1021     if ((data)->last_found)                                          \
1022         Perl_re_printf( aTHX_                                                    \
1023             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
1024             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
1025             SvPVX_const((data)->last_found),                         \
1026             (IV)((data)->last_end),                                  \
1027             (IV)((data)->last_start_min),                            \
1028             (IV)((data)->last_start_max),                            \
1029             ((data)->longest &&                                      \
1030              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
1031             SvPVX_const((data)->longest_fixed),                      \
1032             (IV)((data)->offset_fixed),                              \
1033             ((data)->longest &&                                      \
1034              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
1035             SvPVX_const((data)->longest_float),                      \
1036             (IV)((data)->offset_float_min),                          \
1037             (IV)((data)->offset_float_max)                           \
1038         );                                                           \
1039     Perl_re_printf( aTHX_ "\n");                                                 \
1040 });
1041
1042
1043 /* =========================================================
1044  * BEGIN edit_distance stuff.
1045  *
1046  * This calculates how many single character changes of any type are needed to
1047  * transform a string into another one.  It is taken from version 3.1 of
1048  *
1049  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1050  */
1051
1052 /* Our unsorted dictionary linked list.   */
1053 /* Note we use UVs, not chars. */
1054
1055 struct dictionary{
1056   UV key;
1057   UV value;
1058   struct dictionary* next;
1059 };
1060 typedef struct dictionary item;
1061
1062
1063 PERL_STATIC_INLINE item*
1064 push(UV key,item* curr)
1065 {
1066     item* head;
1067     Newxz(head, 1, item);
1068     head->key = key;
1069     head->value = 0;
1070     head->next = curr;
1071     return head;
1072 }
1073
1074
1075 PERL_STATIC_INLINE item*
1076 find(item* head, UV key)
1077 {
1078     item* iterator = head;
1079     while (iterator){
1080         if (iterator->key == key){
1081             return iterator;
1082         }
1083         iterator = iterator->next;
1084     }
1085
1086     return NULL;
1087 }
1088
1089 PERL_STATIC_INLINE item*
1090 uniquePush(item* head,UV key)
1091 {
1092     item* iterator = head;
1093
1094     while (iterator){
1095         if (iterator->key == key) {
1096             return head;
1097         }
1098         iterator = iterator->next;
1099     }
1100
1101     return push(key,head);
1102 }
1103
1104 PERL_STATIC_INLINE void
1105 dict_free(item* head)
1106 {
1107     item* iterator = head;
1108
1109     while (iterator) {
1110         item* temp = iterator;
1111         iterator = iterator->next;
1112         Safefree(temp);
1113     }
1114
1115     head = NULL;
1116 }
1117
1118 /* End of Dictionary Stuff */
1119
1120 /* All calculations/work are done here */
1121 STATIC int
1122 S_edit_distance(const UV* src,
1123                 const UV* tgt,
1124                 const STRLEN x,             /* length of src[] */
1125                 const STRLEN y,             /* length of tgt[] */
1126                 const SSize_t maxDistance
1127 )
1128 {
1129     item *head = NULL;
1130     UV swapCount,swapScore,targetCharCount,i,j;
1131     UV *scores;
1132     UV score_ceil = x + y;
1133
1134     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1135
1136     /* intialize matrix start values */
1137     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1138     scores[0] = score_ceil;
1139     scores[1 * (y + 2) + 0] = score_ceil;
1140     scores[0 * (y + 2) + 1] = score_ceil;
1141     scores[1 * (y + 2) + 1] = 0;
1142     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1143
1144     /* work loops    */
1145     /* i = src index */
1146     /* j = tgt index */
1147     for (i=1;i<=x;i++) {
1148         if (i < x)
1149             head = uniquePush(head,src[i]);
1150         scores[(i+1) * (y + 2) + 1] = i;
1151         scores[(i+1) * (y + 2) + 0] = score_ceil;
1152         swapCount = 0;
1153
1154         for (j=1;j<=y;j++) {
1155             if (i == 1) {
1156                 if(j < y)
1157                 head = uniquePush(head,tgt[j]);
1158                 scores[1 * (y + 2) + (j + 1)] = j;
1159                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1160             }
1161
1162             targetCharCount = find(head,tgt[j-1])->value;
1163             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1164
1165             if (src[i-1] != tgt[j-1]){
1166                 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));
1167             }
1168             else {
1169                 swapCount = j;
1170                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1171             }
1172         }
1173
1174         find(head,src[i-1])->value = i;
1175     }
1176
1177     {
1178         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1179         dict_free(head);
1180         Safefree(scores);
1181         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1182     }
1183 }
1184
1185 /* END of edit_distance() stuff
1186  * ========================================================= */
1187
1188 /* is c a control character for which we have a mnemonic? */
1189 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1190
1191 STATIC const char *
1192 S_cntrl_to_mnemonic(const U8 c)
1193 {
1194     /* Returns the mnemonic string that represents character 'c', if one
1195      * exists; NULL otherwise.  The only ones that exist for the purposes of
1196      * this routine are a few control characters */
1197
1198     switch (c) {
1199         case '\a':       return "\\a";
1200         case '\b':       return "\\b";
1201         case ESC_NATIVE: return "\\e";
1202         case '\f':       return "\\f";
1203         case '\n':       return "\\n";
1204         case '\r':       return "\\r";
1205         case '\t':       return "\\t";
1206     }
1207
1208     return NULL;
1209 }
1210
1211 /* Mark that we cannot extend a found fixed substring at this point.
1212    Update the longest found anchored substring and the longest found
1213    floating substrings if needed. */
1214
1215 STATIC void
1216 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1217                     SSize_t *minlenp, int is_inf)
1218 {
1219     const STRLEN l = CHR_SVLEN(data->last_found);
1220     const STRLEN old_l = CHR_SVLEN(*data->longest);
1221     GET_RE_DEBUG_FLAGS_DECL;
1222
1223     PERL_ARGS_ASSERT_SCAN_COMMIT;
1224
1225     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1226         SvSetMagicSV(*data->longest, data->last_found);
1227         if (*data->longest == data->longest_fixed) {
1228             data->offset_fixed = l ? data->last_start_min : data->pos_min;
1229             if (data->flags & SF_BEFORE_EOL)
1230                 data->flags
1231                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
1232             else
1233                 data->flags &= ~SF_FIX_BEFORE_EOL;
1234             data->minlen_fixed=minlenp;
1235             data->lookbehind_fixed=0;
1236         }
1237         else { /* *data->longest == data->longest_float */
1238             data->offset_float_min = l ? data->last_start_min : data->pos_min;
1239             data->offset_float_max = (l
1240                           ? data->last_start_max
1241                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1242                                          ? SSize_t_MAX
1243                                          : data->pos_min + data->pos_delta));
1244             if (is_inf
1245                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
1246                 data->offset_float_max = SSize_t_MAX;
1247             if (data->flags & SF_BEFORE_EOL)
1248                 data->flags
1249                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
1250             else
1251                 data->flags &= ~SF_FL_BEFORE_EOL;
1252             data->minlen_float=minlenp;
1253             data->lookbehind_float=0;
1254         }
1255     }
1256     SvCUR_set(data->last_found, 0);
1257     {
1258         SV * const sv = data->last_found;
1259         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1260             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1261             if (mg)
1262                 mg->mg_len = 0;
1263         }
1264     }
1265     data->last_end = -1;
1266     data->flags &= ~SF_BEFORE_EOL;
1267     DEBUG_STUDYDATA("commit: ",data,0);
1268 }
1269
1270 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1271  * list that describes which code points it matches */
1272
1273 STATIC void
1274 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1275 {
1276     /* Set the SSC 'ssc' to match an empty string or any code point */
1277
1278     PERL_ARGS_ASSERT_SSC_ANYTHING;
1279
1280     assert(is_ANYOF_SYNTHETIC(ssc));
1281
1282     ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */
1283     _append_range_to_invlist(ssc->invlist, 0, UV_MAX);
1284     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1285 }
1286
1287 STATIC int
1288 S_ssc_is_anything(const regnode_ssc *ssc)
1289 {
1290     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1291      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1292      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1293      * in any way, so there's no point in using it */
1294
1295     UV start, end;
1296     bool ret;
1297
1298     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1299
1300     assert(is_ANYOF_SYNTHETIC(ssc));
1301
1302     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1303         return FALSE;
1304     }
1305
1306     /* See if the list consists solely of the range 0 - Infinity */
1307     invlist_iterinit(ssc->invlist);
1308     ret = invlist_iternext(ssc->invlist, &start, &end)
1309           && start == 0
1310           && end == UV_MAX;
1311
1312     invlist_iterfinish(ssc->invlist);
1313
1314     if (ret) {
1315         return TRUE;
1316     }
1317
1318     /* If e.g., both \w and \W are set, matches everything */
1319     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1320         int i;
1321         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1322             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1323                 return TRUE;
1324             }
1325         }
1326     }
1327
1328     return FALSE;
1329 }
1330
1331 STATIC void
1332 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1333 {
1334     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1335      * string, any code point, or any posix class under locale */
1336
1337     PERL_ARGS_ASSERT_SSC_INIT;
1338
1339     Zero(ssc, 1, regnode_ssc);
1340     set_ANYOF_SYNTHETIC(ssc);
1341     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1342     ssc_anything(ssc);
1343
1344     /* If any portion of the regex is to operate under locale rules that aren't
1345      * fully known at compile time, initialization includes it.  The reason
1346      * this isn't done for all regexes is that the optimizer was written under
1347      * the assumption that locale was all-or-nothing.  Given the complexity and
1348      * lack of documentation in the optimizer, and that there are inadequate
1349      * test cases for locale, many parts of it may not work properly, it is
1350      * safest to avoid locale unless necessary. */
1351     if (RExC_contains_locale) {
1352         ANYOF_POSIXL_SETALL(ssc);
1353     }
1354     else {
1355         ANYOF_POSIXL_ZERO(ssc);
1356     }
1357 }
1358
1359 STATIC int
1360 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1361                         const regnode_ssc *ssc)
1362 {
1363     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1364      * to the list of code points matched, and locale posix classes; hence does
1365      * not check its flags) */
1366
1367     UV start, end;
1368     bool ret;
1369
1370     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1371
1372     assert(is_ANYOF_SYNTHETIC(ssc));
1373
1374     invlist_iterinit(ssc->invlist);
1375     ret = invlist_iternext(ssc->invlist, &start, &end)
1376           && start == 0
1377           && end == UV_MAX;
1378
1379     invlist_iterfinish(ssc->invlist);
1380
1381     if (! ret) {
1382         return FALSE;
1383     }
1384
1385     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1386         return FALSE;
1387     }
1388
1389     return TRUE;
1390 }
1391
1392 STATIC SV*
1393 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1394                                const regnode_charclass* const node)
1395 {
1396     /* Returns a mortal inversion list defining which code points are matched
1397      * by 'node', which is of type ANYOF.  Handles complementing the result if
1398      * appropriate.  If some code points aren't knowable at this time, the
1399      * returned list must, and will, contain every code point that is a
1400      * possibility. */
1401
1402     SV* invlist = NULL;
1403     SV* only_utf8_locale_invlist = NULL;
1404     unsigned int i;
1405     const U32 n = ARG(node);
1406     bool new_node_has_latin1 = FALSE;
1407
1408     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1409
1410     /* Look at the data structure created by S_set_ANYOF_arg() */
1411     if (n != ANYOF_ONLY_HAS_BITMAP) {
1412         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1413         AV * const av = MUTABLE_AV(SvRV(rv));
1414         SV **const ary = AvARRAY(av);
1415         assert(RExC_rxi->data->what[n] == 's');
1416
1417         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1418             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1419         }
1420         else if (ary[0] && ary[0] != &PL_sv_undef) {
1421
1422             /* Here, no compile-time swash, and there are things that won't be
1423              * known until runtime -- we have to assume it could be anything */
1424             invlist = sv_2mortal(_new_invlist(1));
1425             return _add_range_to_invlist(invlist, 0, UV_MAX);
1426         }
1427         else if (ary[3] && ary[3] != &PL_sv_undef) {
1428
1429             /* Here no compile-time swash, and no run-time only data.  Use the
1430              * node's inversion list */
1431             invlist = sv_2mortal(invlist_clone(ary[3]));
1432         }
1433
1434         /* Get the code points valid only under UTF-8 locales */
1435         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1436             && ary[2] && ary[2] != &PL_sv_undef)
1437         {
1438             only_utf8_locale_invlist = ary[2];
1439         }
1440     }
1441
1442     if (! invlist) {
1443         invlist = sv_2mortal(_new_invlist(0));
1444     }
1445
1446     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1447      * code points, and an inversion list for the others, but if there are code
1448      * points that should match only conditionally on the target string being
1449      * UTF-8, those are placed in the inversion list, and not the bitmap.
1450      * Since there are circumstances under which they could match, they are
1451      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1452      * to exclude them here, so that when we invert below, the end result
1453      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1454      * have to do this here before we add the unconditionally matched code
1455      * points */
1456     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1457         _invlist_intersection_complement_2nd(invlist,
1458                                              PL_UpperLatin1,
1459                                              &invlist);
1460     }
1461
1462     /* Add in the points from the bit map */
1463     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1464         if (ANYOF_BITMAP_TEST(node, i)) {
1465             unsigned int start = i++;
1466
1467             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1468                 /* empty */
1469             }
1470             invlist = _add_range_to_invlist(invlist, start, i-1);
1471             new_node_has_latin1 = TRUE;
1472         }
1473     }
1474
1475     /* If this can match all upper Latin1 code points, have to add them
1476      * as well.  But don't add them if inverting, as when that gets done below,
1477      * it would exclude all these characters, including the ones it shouldn't
1478      * that were added just above */
1479     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1480         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1481     {
1482         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1483     }
1484
1485     /* Similarly for these */
1486     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1487         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1488     }
1489
1490     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1491         _invlist_invert(invlist);
1492     }
1493     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1494
1495         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1496          * locale.  We can skip this if there are no 0-255 at all. */
1497         _invlist_union(invlist, PL_Latin1, &invlist);
1498     }
1499
1500     /* Similarly add the UTF-8 locale possible matches.  These have to be
1501      * deferred until after the non-UTF-8 locale ones are taken care of just
1502      * above, or it leads to wrong results under ANYOF_INVERT */
1503     if (only_utf8_locale_invlist) {
1504         _invlist_union_maybe_complement_2nd(invlist,
1505                                             only_utf8_locale_invlist,
1506                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1507                                             &invlist);
1508     }
1509
1510     return invlist;
1511 }
1512
1513 /* These two functions currently do the exact same thing */
1514 #define ssc_init_zero           ssc_init
1515
1516 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1517 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1518
1519 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1520  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1521  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1522
1523 STATIC void
1524 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1525                 const regnode_charclass *and_with)
1526 {
1527     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1528      * another SSC or a regular ANYOF class.  Can create false positives. */
1529
1530     SV* anded_cp_list;
1531     U8  anded_flags;
1532
1533     PERL_ARGS_ASSERT_SSC_AND;
1534
1535     assert(is_ANYOF_SYNTHETIC(ssc));
1536
1537     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1538      * the code point inversion list and just the relevant flags */
1539     if (is_ANYOF_SYNTHETIC(and_with)) {
1540         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1541         anded_flags = ANYOF_FLAGS(and_with);
1542
1543         /* XXX This is a kludge around what appears to be deficiencies in the
1544          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1545          * there are paths through the optimizer where it doesn't get weeded
1546          * out when it should.  And if we don't make some extra provision for
1547          * it like the code just below, it doesn't get added when it should.
1548          * This solution is to add it only when AND'ing, which is here, and
1549          * only when what is being AND'ed is the pristine, original node
1550          * matching anything.  Thus it is like adding it to ssc_anything() but
1551          * only when the result is to be AND'ed.  Probably the same solution
1552          * could be adopted for the same problem we have with /l matching,
1553          * which is solved differently in S_ssc_init(), and that would lead to
1554          * fewer false positives than that solution has.  But if this solution
1555          * creates bugs, the consequences are only that a warning isn't raised
1556          * that should be; while the consequences for having /l bugs is
1557          * incorrect matches */
1558         if (ssc_is_anything((regnode_ssc *)and_with)) {
1559             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1560         }
1561     }
1562     else {
1563         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1564         if (OP(and_with) == ANYOFD) {
1565             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1566         }
1567         else {
1568             anded_flags = ANYOF_FLAGS(and_with)
1569             &( ANYOF_COMMON_FLAGS
1570               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1571               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1572             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1573                 anded_flags &=
1574                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1575             }
1576         }
1577     }
1578
1579     ANYOF_FLAGS(ssc) &= anded_flags;
1580
1581     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1582      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1583      * 'and_with' may be inverted.  When not inverted, we have the situation of
1584      * computing:
1585      *  (C1 | P1) & (C2 | P2)
1586      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1587      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1588      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1589      *                    <=  ((C1 & C2) | P1 | P2)
1590      * Alternatively, the last few steps could be:
1591      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1592      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1593      *                    <=  (C1 | C2 | (P1 & P2))
1594      * We favor the second approach if either P1 or P2 is non-empty.  This is
1595      * because these components are a barrier to doing optimizations, as what
1596      * they match cannot be known until the moment of matching as they are
1597      * dependent on the current locale, 'AND"ing them likely will reduce or
1598      * eliminate them.
1599      * But we can do better if we know that C1,P1 are in their initial state (a
1600      * frequent occurrence), each matching everything:
1601      *  (<everything>) & (C2 | P2) =  C2 | P2
1602      * Similarly, if C2,P2 are in their initial state (again a frequent
1603      * occurrence), the result is a no-op
1604      *  (C1 | P1) & (<everything>) =  C1 | P1
1605      *
1606      * Inverted, we have
1607      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1608      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1609      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1610      * */
1611
1612     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1613         && ! is_ANYOF_SYNTHETIC(and_with))
1614     {
1615         unsigned int i;
1616
1617         ssc_intersection(ssc,
1618                          anded_cp_list,
1619                          FALSE /* Has already been inverted */
1620                          );
1621
1622         /* If either P1 or P2 is empty, the intersection will be also; can skip
1623          * the loop */
1624         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1625             ANYOF_POSIXL_ZERO(ssc);
1626         }
1627         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1628
1629             /* Note that the Posix class component P from 'and_with' actually
1630              * looks like:
1631              *      P = Pa | Pb | ... | Pn
1632              * where each component is one posix class, such as in [\w\s].
1633              * Thus
1634              *      ~P = ~(Pa | Pb | ... | Pn)
1635              *         = ~Pa & ~Pb & ... & ~Pn
1636              *        <= ~Pa | ~Pb | ... | ~Pn
1637              * The last is something we can easily calculate, but unfortunately
1638              * is likely to have many false positives.  We could do better
1639              * in some (but certainly not all) instances if two classes in
1640              * P have known relationships.  For example
1641              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1642              * So
1643              *      :lower: & :print: = :lower:
1644              * And similarly for classes that must be disjoint.  For example,
1645              * since \s and \w can have no elements in common based on rules in
1646              * the POSIX standard,
1647              *      \w & ^\S = nothing
1648              * Unfortunately, some vendor locales do not meet the Posix
1649              * standard, in particular almost everything by Microsoft.
1650              * The loop below just changes e.g., \w into \W and vice versa */
1651
1652             regnode_charclass_posixl temp;
1653             int add = 1;    /* To calculate the index of the complement */
1654
1655             ANYOF_POSIXL_ZERO(&temp);
1656             for (i = 0; i < ANYOF_MAX; i++) {
1657                 assert(i % 2 != 0
1658                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1659                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1660
1661                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1662                     ANYOF_POSIXL_SET(&temp, i + add);
1663                 }
1664                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1665             }
1666             ANYOF_POSIXL_AND(&temp, ssc);
1667
1668         } /* else ssc already has no posixes */
1669     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1670          in its initial state */
1671     else if (! is_ANYOF_SYNTHETIC(and_with)
1672              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1673     {
1674         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1675          * copy it over 'ssc' */
1676         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1677             if (is_ANYOF_SYNTHETIC(and_with)) {
1678                 StructCopy(and_with, ssc, regnode_ssc);
1679             }
1680             else {
1681                 ssc->invlist = anded_cp_list;
1682                 ANYOF_POSIXL_ZERO(ssc);
1683                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1684                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1685                 }
1686             }
1687         }
1688         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1689                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1690         {
1691             /* One or the other of P1, P2 is non-empty. */
1692             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1693                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1694             }
1695             ssc_union(ssc, anded_cp_list, FALSE);
1696         }
1697         else { /* P1 = P2 = empty */
1698             ssc_intersection(ssc, anded_cp_list, FALSE);
1699         }
1700     }
1701 }
1702
1703 STATIC void
1704 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1705                const regnode_charclass *or_with)
1706 {
1707     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1708      * another SSC or a regular ANYOF class.  Can create false positives if
1709      * 'or_with' is to be inverted. */
1710
1711     SV* ored_cp_list;
1712     U8 ored_flags;
1713
1714     PERL_ARGS_ASSERT_SSC_OR;
1715
1716     assert(is_ANYOF_SYNTHETIC(ssc));
1717
1718     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1719      * the code point inversion list and just the relevant flags */
1720     if (is_ANYOF_SYNTHETIC(or_with)) {
1721         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1722         ored_flags = ANYOF_FLAGS(or_with);
1723     }
1724     else {
1725         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1726         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1727         if (OP(or_with) != ANYOFD) {
1728             ored_flags
1729             |= ANYOF_FLAGS(or_with)
1730              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1731                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1732             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1733                 ored_flags |=
1734                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1735             }
1736         }
1737     }
1738
1739     ANYOF_FLAGS(ssc) |= ored_flags;
1740
1741     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1742      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1743      * 'or_with' may be inverted.  When not inverted, we have the simple
1744      * situation of computing:
1745      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1746      * If P1|P2 yields a situation with both a class and its complement are
1747      * set, like having both \w and \W, this matches all code points, and we
1748      * can delete these from the P component of the ssc going forward.  XXX We
1749      * might be able to delete all the P components, but I (khw) am not certain
1750      * about this, and it is better to be safe.
1751      *
1752      * Inverted, we have
1753      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1754      *                         <=  (C1 | P1) | ~C2
1755      *                         <=  (C1 | ~C2) | P1
1756      * (which results in actually simpler code than the non-inverted case)
1757      * */
1758
1759     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1760         && ! is_ANYOF_SYNTHETIC(or_with))
1761     {
1762         /* We ignore P2, leaving P1 going forward */
1763     }   /* else  Not inverted */
1764     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1765         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1766         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1767             unsigned int i;
1768             for (i = 0; i < ANYOF_MAX; i += 2) {
1769                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1770                 {
1771                     ssc_match_all_cp(ssc);
1772                     ANYOF_POSIXL_CLEAR(ssc, i);
1773                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1774                 }
1775             }
1776         }
1777     }
1778
1779     ssc_union(ssc,
1780               ored_cp_list,
1781               FALSE /* Already has been inverted */
1782               );
1783 }
1784
1785 PERL_STATIC_INLINE void
1786 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1787 {
1788     PERL_ARGS_ASSERT_SSC_UNION;
1789
1790     assert(is_ANYOF_SYNTHETIC(ssc));
1791
1792     _invlist_union_maybe_complement_2nd(ssc->invlist,
1793                                         invlist,
1794                                         invert2nd,
1795                                         &ssc->invlist);
1796 }
1797
1798 PERL_STATIC_INLINE void
1799 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1800                          SV* const invlist,
1801                          const bool invert2nd)
1802 {
1803     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1804
1805     assert(is_ANYOF_SYNTHETIC(ssc));
1806
1807     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1808                                                invlist,
1809                                                invert2nd,
1810                                                &ssc->invlist);
1811 }
1812
1813 PERL_STATIC_INLINE void
1814 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1815 {
1816     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1817
1818     assert(is_ANYOF_SYNTHETIC(ssc));
1819
1820     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1821 }
1822
1823 PERL_STATIC_INLINE void
1824 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1825 {
1826     /* AND just the single code point 'cp' into the SSC 'ssc' */
1827
1828     SV* cp_list = _new_invlist(2);
1829
1830     PERL_ARGS_ASSERT_SSC_CP_AND;
1831
1832     assert(is_ANYOF_SYNTHETIC(ssc));
1833
1834     cp_list = add_cp_to_invlist(cp_list, cp);
1835     ssc_intersection(ssc, cp_list,
1836                      FALSE /* Not inverted */
1837                      );
1838     SvREFCNT_dec_NN(cp_list);
1839 }
1840
1841 PERL_STATIC_INLINE void
1842 S_ssc_clear_locale(regnode_ssc *ssc)
1843 {
1844     /* Set the SSC 'ssc' to not match any locale things */
1845     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1846
1847     assert(is_ANYOF_SYNTHETIC(ssc));
1848
1849     ANYOF_POSIXL_ZERO(ssc);
1850     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1851 }
1852
1853 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1854
1855 STATIC bool
1856 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1857 {
1858     /* The synthetic start class is used to hopefully quickly winnow down
1859      * places where a pattern could start a match in the target string.  If it
1860      * doesn't really narrow things down that much, there isn't much point to
1861      * having the overhead of using it.  This function uses some very crude
1862      * heuristics to decide if to use the ssc or not.
1863      *
1864      * It returns TRUE if 'ssc' rules out more than half what it considers to
1865      * be the "likely" possible matches, but of course it doesn't know what the
1866      * actual things being matched are going to be; these are only guesses
1867      *
1868      * For /l matches, it assumes that the only likely matches are going to be
1869      *      in the 0-255 range, uniformly distributed, so half of that is 127
1870      * For /a and /d matches, it assumes that the likely matches will be just
1871      *      the ASCII range, so half of that is 63
1872      * For /u and there isn't anything matching above the Latin1 range, it
1873      *      assumes that that is the only range likely to be matched, and uses
1874      *      half that as the cut-off: 127.  If anything matches above Latin1,
1875      *      it assumes that all of Unicode could match (uniformly), except for
1876      *      non-Unicode code points and things in the General Category "Other"
1877      *      (unassigned, private use, surrogates, controls and formats).  This
1878      *      is a much large number. */
1879
1880     U32 count = 0;      /* Running total of number of code points matched by
1881                            'ssc' */
1882     UV start, end;      /* Start and end points of current range in inversion
1883                            list */
1884     const U32 max_code_points = (LOC)
1885                                 ?  256
1886                                 : ((   ! UNI_SEMANTICS
1887                                      || invlist_highest(ssc->invlist) < 256)
1888                                   ? 128
1889                                   : NON_OTHER_COUNT);
1890     const U32 max_match = max_code_points / 2;
1891
1892     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1893
1894     invlist_iterinit(ssc->invlist);
1895     while (invlist_iternext(ssc->invlist, &start, &end)) {
1896         if (start >= max_code_points) {
1897             break;
1898         }
1899         end = MIN(end, max_code_points - 1);
1900         count += end - start + 1;
1901         if (count >= max_match) {
1902             invlist_iterfinish(ssc->invlist);
1903             return FALSE;
1904         }
1905     }
1906
1907     return TRUE;
1908 }
1909
1910
1911 STATIC void
1912 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1913 {
1914     /* The inversion list in the SSC is marked mortal; now we need a more
1915      * permanent copy, which is stored the same way that is done in a regular
1916      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1917      * map */
1918
1919     SV* invlist = invlist_clone(ssc->invlist);
1920
1921     PERL_ARGS_ASSERT_SSC_FINALIZE;
1922
1923     assert(is_ANYOF_SYNTHETIC(ssc));
1924
1925     /* The code in this file assumes that all but these flags aren't relevant
1926      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1927      * by the time we reach here */
1928     assert(! (ANYOF_FLAGS(ssc)
1929         & ~( ANYOF_COMMON_FLAGS
1930             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1931             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
1932
1933     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1934
1935     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1936                                 NULL, NULL, NULL, FALSE);
1937
1938     /* Make sure is clone-safe */
1939     ssc->invlist = NULL;
1940
1941     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1942         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1943     }
1944
1945     if (RExC_contains_locale) {
1946         OP(ssc) = ANYOFL;
1947     }
1948
1949     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1950 }
1951
1952 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1953 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1954 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1955 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1956                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1957                                : 0 )
1958
1959
1960 #ifdef DEBUGGING
1961 /*
1962    dump_trie(trie,widecharmap,revcharmap)
1963    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1964    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1965
1966    These routines dump out a trie in a somewhat readable format.
1967    The _interim_ variants are used for debugging the interim
1968    tables that are used to generate the final compressed
1969    representation which is what dump_trie expects.
1970
1971    Part of the reason for their existence is to provide a form
1972    of documentation as to how the different representations function.
1973
1974 */
1975
1976 /*
1977   Dumps the final compressed table form of the trie to Perl_debug_log.
1978   Used for debugging make_trie().
1979 */
1980
1981 STATIC void
1982 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1983             AV *revcharmap, U32 depth)
1984 {
1985     U32 state;
1986     SV *sv=sv_newmortal();
1987     int colwidth= widecharmap ? 6 : 4;
1988     U16 word;
1989     GET_RE_DEBUG_FLAGS_DECL;
1990
1991     PERL_ARGS_ASSERT_DUMP_TRIE;
1992
1993     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
1994         depth+1, "Match","Base","Ofs" );
1995
1996     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1997         SV ** const tmp = av_fetch( revcharmap, state, 0);
1998         if ( tmp ) {
1999             Perl_re_printf( aTHX_  "%*s",
2000                 colwidth,
2001                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2002                             PL_colors[0], PL_colors[1],
2003                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2004                             PERL_PV_ESCAPE_FIRSTCHAR
2005                 )
2006             );
2007         }
2008     }
2009     Perl_re_printf( aTHX_  "\n");
2010     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2011
2012     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2013         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2014     Perl_re_printf( aTHX_  "\n");
2015
2016     for( state = 1 ; state < trie->statecount ; state++ ) {
2017         const U32 base = trie->states[ state ].trans.base;
2018
2019         Perl_re_indentf( aTHX_  "#%4"UVXf"|", depth+1, (UV)state);
2020
2021         if ( trie->states[ state ].wordnum ) {
2022             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2023         } else {
2024             Perl_re_printf( aTHX_  "%6s", "" );
2025         }
2026
2027         Perl_re_printf( aTHX_  " @%4"UVXf" ", (UV)base );
2028
2029         if ( base ) {
2030             U32 ofs = 0;
2031
2032             while( ( base + ofs  < trie->uniquecharcount ) ||
2033                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2034                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2035                                                                     != state))
2036                     ofs++;
2037
2038             Perl_re_printf( aTHX_  "+%2"UVXf"[ ", (UV)ofs);
2039
2040             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2041                 if ( ( base + ofs >= trie->uniquecharcount )
2042                         && ( base + ofs - trie->uniquecharcount
2043                                                         < trie->lasttrans )
2044                         && trie->trans[ base + ofs
2045                                     - trie->uniquecharcount ].check == state )
2046                 {
2047                    Perl_re_printf( aTHX_  "%*"UVXf, colwidth,
2048                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2049                    );
2050                 } else {
2051                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2052                 }
2053             }
2054
2055             Perl_re_printf( aTHX_  "]");
2056
2057         }
2058         Perl_re_printf( aTHX_  "\n" );
2059     }
2060     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2061                                 depth);
2062     for (word=1; word <= trie->wordcount; word++) {
2063         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2064             (int)word, (int)(trie->wordinfo[word].prev),
2065             (int)(trie->wordinfo[word].len));
2066     }
2067     Perl_re_printf( aTHX_  "\n" );
2068 }
2069 /*
2070   Dumps a fully constructed but uncompressed trie in list form.
2071   List tries normally only are used for construction when the number of
2072   possible chars (trie->uniquecharcount) is very high.
2073   Used for debugging make_trie().
2074 */
2075 STATIC void
2076 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2077                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2078                          U32 depth)
2079 {
2080     U32 state;
2081     SV *sv=sv_newmortal();
2082     int colwidth= widecharmap ? 6 : 4;
2083     GET_RE_DEBUG_FLAGS_DECL;
2084
2085     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2086
2087     /* print out the table precompression.  */
2088     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2089             depth+1 );
2090     Perl_re_indentf( aTHX_  "%s",
2091             depth+1, "------:-----+-----------------\n" );
2092
2093     for( state=1 ; state < next_alloc ; state ++ ) {
2094         U16 charid;
2095
2096         Perl_re_indentf( aTHX_  " %4"UVXf" :",
2097             depth+1, (UV)state  );
2098         if ( ! trie->states[ state ].wordnum ) {
2099             Perl_re_printf( aTHX_  "%5s| ","");
2100         } else {
2101             Perl_re_printf( aTHX_  "W%4x| ",
2102                 trie->states[ state ].wordnum
2103             );
2104         }
2105         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2106             SV ** const tmp = av_fetch( revcharmap,
2107                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2108             if ( tmp ) {
2109                 Perl_re_printf( aTHX_  "%*s:%3X=%4"UVXf" | ",
2110                     colwidth,
2111                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2112                               colwidth,
2113                               PL_colors[0], PL_colors[1],
2114                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2115                               | PERL_PV_ESCAPE_FIRSTCHAR
2116                     ) ,
2117                     TRIE_LIST_ITEM(state,charid).forid,
2118                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2119                 );
2120                 if (!(charid % 10))
2121                     Perl_re_printf( aTHX_  "\n%*s| ",
2122                         (int)((depth * 2) + 14), "");
2123             }
2124         }
2125         Perl_re_printf( aTHX_  "\n");
2126     }
2127 }
2128
2129 /*
2130   Dumps a fully constructed but uncompressed trie in table form.
2131   This is the normal DFA style state transition table, with a few
2132   twists to facilitate compression later.
2133   Used for debugging make_trie().
2134 */
2135 STATIC void
2136 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2137                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2138                           U32 depth)
2139 {
2140     U32 state;
2141     U16 charid;
2142     SV *sv=sv_newmortal();
2143     int colwidth= widecharmap ? 6 : 4;
2144     GET_RE_DEBUG_FLAGS_DECL;
2145
2146     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2147
2148     /*
2149        print out the table precompression so that we can do a visual check
2150        that they are identical.
2151      */
2152
2153     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2154
2155     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2156         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2157         if ( tmp ) {
2158             Perl_re_printf( aTHX_  "%*s",
2159                 colwidth,
2160                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2161                             PL_colors[0], PL_colors[1],
2162                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2163                             PERL_PV_ESCAPE_FIRSTCHAR
2164                 )
2165             );
2166         }
2167     }
2168
2169     Perl_re_printf( aTHX_ "\n");
2170     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2171
2172     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2173         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2174     }
2175
2176     Perl_re_printf( aTHX_  "\n" );
2177
2178     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2179
2180         Perl_re_indentf( aTHX_  "%4"UVXf" : ",
2181             depth+1,
2182             (UV)TRIE_NODENUM( state ) );
2183
2184         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2185             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2186             if (v)
2187                 Perl_re_printf( aTHX_  "%*"UVXf, colwidth, v );
2188             else
2189                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2190         }
2191         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2192             Perl_re_printf( aTHX_  " (%4"UVXf")\n",
2193                                             (UV)trie->trans[ state ].check );
2194         } else {
2195             Perl_re_printf( aTHX_  " (%4"UVXf") W%4X\n",
2196                                             (UV)trie->trans[ state ].check,
2197             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2198         }
2199     }
2200 }
2201
2202 #endif
2203
2204
2205 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2206   startbranch: the first branch in the whole branch sequence
2207   first      : start branch of sequence of branch-exact nodes.
2208                May be the same as startbranch
2209   last       : Thing following the last branch.
2210                May be the same as tail.
2211   tail       : item following the branch sequence
2212   count      : words in the sequence
2213   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2214   depth      : indent depth
2215
2216 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2217
2218 A trie is an N'ary tree where the branches are determined by digital
2219 decomposition of the key. IE, at the root node you look up the 1st character and
2220 follow that branch repeat until you find the end of the branches. Nodes can be
2221 marked as "accepting" meaning they represent a complete word. Eg:
2222
2223   /he|she|his|hers/
2224
2225 would convert into the following structure. Numbers represent states, letters
2226 following numbers represent valid transitions on the letter from that state, if
2227 the number is in square brackets it represents an accepting state, otherwise it
2228 will be in parenthesis.
2229
2230       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2231       |    |
2232       |   (2)
2233       |    |
2234      (1)   +-i->(6)-+-s->[7]
2235       |
2236       +-s->(3)-+-h->(4)-+-e->[5]
2237
2238       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2239
2240 This shows that when matching against the string 'hers' we will begin at state 1
2241 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2242 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2243 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2244 single traverse. We store a mapping from accepting to state to which word was
2245 matched, and then when we have multiple possibilities we try to complete the
2246 rest of the regex in the order in which they occurred in the alternation.
2247
2248 The only prior NFA like behaviour that would be changed by the TRIE support is
2249 the silent ignoring of duplicate alternations which are of the form:
2250
2251  / (DUPE|DUPE) X? (?{ ... }) Y /x
2252
2253 Thus EVAL blocks following a trie may be called a different number of times with
2254 and without the optimisation. With the optimisations dupes will be silently
2255 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2256 the following demonstrates:
2257
2258  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2259
2260 which prints out 'word' three times, but
2261
2262  'words'=~/(word|word|word)(?{ print $1 })S/
2263
2264 which doesnt print it out at all. This is due to other optimisations kicking in.
2265
2266 Example of what happens on a structural level:
2267
2268 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2269
2270    1: CURLYM[1] {1,32767}(18)
2271    5:   BRANCH(8)
2272    6:     EXACT <ac>(16)
2273    8:   BRANCH(11)
2274    9:     EXACT <ad>(16)
2275   11:   BRANCH(14)
2276   12:     EXACT <ab>(16)
2277   16:   SUCCEED(0)
2278   17:   NOTHING(18)
2279   18: END(0)
2280
2281 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2282 and should turn into:
2283
2284    1: CURLYM[1] {1,32767}(18)
2285    5:   TRIE(16)
2286         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2287           <ac>
2288           <ad>
2289           <ab>
2290   16:   SUCCEED(0)
2291   17:   NOTHING(18)
2292   18: END(0)
2293
2294 Cases where tail != last would be like /(?foo|bar)baz/:
2295
2296    1: BRANCH(4)
2297    2:   EXACT <foo>(8)
2298    4: BRANCH(7)
2299    5:   EXACT <bar>(8)
2300    7: TAIL(8)
2301    8: EXACT <baz>(10)
2302   10: END(0)
2303
2304 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2305 and would end up looking like:
2306
2307     1: TRIE(8)
2308       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2309         <foo>
2310         <bar>
2311    7: TAIL(8)
2312    8: EXACT <baz>(10)
2313   10: END(0)
2314
2315     d = uvchr_to_utf8_flags(d, uv, 0);
2316
2317 is the recommended Unicode-aware way of saying
2318
2319     *(d++) = uv;
2320 */
2321
2322 #define TRIE_STORE_REVCHAR(val)                                            \
2323     STMT_START {                                                           \
2324         if (UTF) {                                                         \
2325             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2326             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2327             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2328             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2329             SvPOK_on(zlopp);                                               \
2330             SvUTF8_on(zlopp);                                              \
2331             av_push(revcharmap, zlopp);                                    \
2332         } else {                                                           \
2333             char ooooff = (char)val;                                           \
2334             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2335         }                                                                  \
2336         } STMT_END
2337
2338 /* This gets the next character from the input, folding it if not already
2339  * folded. */
2340 #define TRIE_READ_CHAR STMT_START {                                           \
2341     wordlen++;                                                                \
2342     if ( UTF ) {                                                              \
2343         /* if it is UTF then it is either already folded, or does not need    \
2344          * folding */                                                         \
2345         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2346     }                                                                         \
2347     else if (folder == PL_fold_latin1) {                                      \
2348         /* This folder implies Unicode rules, which in the range expressible  \
2349          *  by not UTF is the lower case, with the two exceptions, one of     \
2350          *  which should have been taken care of before calling this */       \
2351         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2352         uvc = toLOWER_L1(*uc);                                                \
2353         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2354         len = 1;                                                              \
2355     } else {                                                                  \
2356         /* raw data, will be folded later if needed */                        \
2357         uvc = (U32)*uc;                                                       \
2358         len = 1;                                                              \
2359     }                                                                         \
2360 } STMT_END
2361
2362
2363
2364 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2365     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2366         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
2367         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2368     }                                                           \
2369     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2370     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2371     TRIE_LIST_CUR( state )++;                                   \
2372 } STMT_END
2373
2374 #define TRIE_LIST_NEW(state) STMT_START {                       \
2375     Newxz( trie->states[ state ].trans.list,               \
2376         4, reg_trie_trans_le );                                 \
2377      TRIE_LIST_CUR( state ) = 1;                                \
2378      TRIE_LIST_LEN( state ) = 4;                                \
2379 } STMT_END
2380
2381 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2382     U16 dupe= trie->states[ state ].wordnum;                    \
2383     regnode * const noper_next = regnext( noper );              \
2384                                                                 \
2385     DEBUG_r({                                                   \
2386         /* store the word for dumping */                        \
2387         SV* tmp;                                                \
2388         if (OP(noper) != NOTHING)                               \
2389             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2390         else                                                    \
2391             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2392         av_push( trie_words, tmp );                             \
2393     });                                                         \
2394                                                                 \
2395     curword++;                                                  \
2396     trie->wordinfo[curword].prev   = 0;                         \
2397     trie->wordinfo[curword].len    = wordlen;                   \
2398     trie->wordinfo[curword].accept = state;                     \
2399                                                                 \
2400     if ( noper_next < tail ) {                                  \
2401         if (!trie->jump)                                        \
2402             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2403                                                  sizeof(U16) ); \
2404         trie->jump[curword] = (U16)(noper_next - convert);      \
2405         if (!jumper)                                            \
2406             jumper = noper_next;                                \
2407         if (!nextbranch)                                        \
2408             nextbranch= regnext(cur);                           \
2409     }                                                           \
2410                                                                 \
2411     if ( dupe ) {                                               \
2412         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2413         /* chain, so that when the bits of chain are later    */\
2414         /* linked together, the dups appear in the chain      */\
2415         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2416         trie->wordinfo[dupe].prev = curword;                    \
2417     } else {                                                    \
2418         /* we haven't inserted this word yet.                */ \
2419         trie->states[ state ].wordnum = curword;                \
2420     }                                                           \
2421 } STMT_END
2422
2423
2424 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2425      ( ( base + charid >=  ucharcount                                   \
2426          && base + charid < ubound                                      \
2427          && state == trie->trans[ base - ucharcount + charid ].check    \
2428          && trie->trans[ base - ucharcount + charid ].next )            \
2429            ? trie->trans[ base - ucharcount + charid ].next             \
2430            : ( state==1 ? special : 0 )                                 \
2431       )
2432
2433 #define MADE_TRIE       1
2434 #define MADE_JUMP_TRIE  2
2435 #define MADE_EXACT_TRIE 4
2436
2437 STATIC I32
2438 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2439                   regnode *first, regnode *last, regnode *tail,
2440                   U32 word_count, U32 flags, U32 depth)
2441 {
2442     /* first pass, loop through and scan words */
2443     reg_trie_data *trie;
2444     HV *widecharmap = NULL;
2445     AV *revcharmap = newAV();
2446     regnode *cur;
2447     STRLEN len = 0;
2448     UV uvc = 0;
2449     U16 curword = 0;
2450     U32 next_alloc = 0;
2451     regnode *jumper = NULL;
2452     regnode *nextbranch = NULL;
2453     regnode *convert = NULL;
2454     U32 *prev_states; /* temp array mapping each state to previous one */
2455     /* we just use folder as a flag in utf8 */
2456     const U8 * folder = NULL;
2457
2458 #ifdef DEBUGGING
2459     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2460     AV *trie_words = NULL;
2461     /* along with revcharmap, this only used during construction but both are
2462      * useful during debugging so we store them in the struct when debugging.
2463      */
2464 #else
2465     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2466     STRLEN trie_charcount=0;
2467 #endif
2468     SV *re_trie_maxbuff;
2469     GET_RE_DEBUG_FLAGS_DECL;
2470
2471     PERL_ARGS_ASSERT_MAKE_TRIE;
2472 #ifndef DEBUGGING
2473     PERL_UNUSED_ARG(depth);
2474 #endif
2475
2476     switch (flags) {
2477         case EXACT: case EXACTL: break;
2478         case EXACTFA:
2479         case EXACTFU_SS:
2480         case EXACTFU:
2481         case EXACTFLU8: folder = PL_fold_latin1; break;
2482         case EXACTF:  folder = PL_fold; break;
2483         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2484     }
2485
2486     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2487     trie->refcount = 1;
2488     trie->startstate = 1;
2489     trie->wordcount = word_count;
2490     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2491     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2492     if (flags == EXACT || flags == EXACTL)
2493         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2494     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2495                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2496
2497     DEBUG_r({
2498         trie_words = newAV();
2499     });
2500
2501     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2502     assert(re_trie_maxbuff);
2503     if (!SvIOK(re_trie_maxbuff)) {
2504         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2505     }
2506     DEBUG_TRIE_COMPILE_r({
2507         Perl_re_indentf( aTHX_
2508           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2509           depth+1,
2510           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2511           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2512     });
2513
2514    /* Find the node we are going to overwrite */
2515     if ( first == startbranch && OP( last ) != BRANCH ) {
2516         /* whole branch chain */
2517         convert = first;
2518     } else {
2519         /* branch sub-chain */
2520         convert = NEXTOPER( first );
2521     }
2522
2523     /*  -- First loop and Setup --
2524
2525        We first traverse the branches and scan each word to determine if it
2526        contains widechars, and how many unique chars there are, this is
2527        important as we have to build a table with at least as many columns as we
2528        have unique chars.
2529
2530        We use an array of integers to represent the character codes 0..255
2531        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2532        the native representation of the character value as the key and IV's for
2533        the coded index.
2534
2535        *TODO* If we keep track of how many times each character is used we can
2536        remap the columns so that the table compression later on is more
2537        efficient in terms of memory by ensuring the most common value is in the
2538        middle and the least common are on the outside.  IMO this would be better
2539        than a most to least common mapping as theres a decent chance the most
2540        common letter will share a node with the least common, meaning the node
2541        will not be compressible. With a middle is most common approach the worst
2542        case is when we have the least common nodes twice.
2543
2544      */
2545
2546     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2547         regnode *noper = NEXTOPER( cur );
2548         const U8 *uc;
2549         const U8 *e;
2550         int foldlen = 0;
2551         U32 wordlen      = 0;         /* required init */
2552         STRLEN minchars = 0;
2553         STRLEN maxchars = 0;
2554         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2555                                                bitmap?*/
2556
2557         if (OP(noper) == NOTHING) {
2558             regnode *noper_next= regnext(noper);
2559             if (noper_next < tail)
2560                 noper= noper_next;
2561         }
2562
2563         if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2564             uc= (U8*)STRING(noper);
2565             e= uc + STR_LEN(noper);
2566         } else {
2567             trie->minlen= 0;
2568             continue;
2569         }
2570
2571
2572         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2573             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2574                                           regardless of encoding */
2575             if (OP( noper ) == EXACTFU_SS) {
2576                 /* false positives are ok, so just set this */
2577                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2578             }
2579         }
2580         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2581                                            branch */
2582             TRIE_CHARCOUNT(trie)++;
2583             TRIE_READ_CHAR;
2584
2585             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2586              * is in effect.  Under /i, this character can match itself, or
2587              * anything that folds to it.  If not under /i, it can match just
2588              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2589              * all fold to k, and all are single characters.   But some folds
2590              * expand to more than one character, so for example LATIN SMALL
2591              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2592              * the string beginning at 'uc' is 'ffi', it could be matched by
2593              * three characters, or just by the one ligature character. (It
2594              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2595              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2596              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2597              * match.)  The trie needs to know the minimum and maximum number
2598              * of characters that could match so that it can use size alone to
2599              * quickly reject many match attempts.  The max is simple: it is
2600              * the number of folded characters in this branch (since a fold is
2601              * never shorter than what folds to it. */
2602
2603             maxchars++;
2604
2605             /* And the min is equal to the max if not under /i (indicated by
2606              * 'folder' being NULL), or there are no multi-character folds.  If
2607              * there is a multi-character fold, the min is incremented just
2608              * once, for the character that folds to the sequence.  Each
2609              * character in the sequence needs to be added to the list below of
2610              * characters in the trie, but we count only the first towards the
2611              * min number of characters needed.  This is done through the
2612              * variable 'foldlen', which is returned by the macros that look
2613              * for these sequences as the number of bytes the sequence
2614              * occupies.  Each time through the loop, we decrement 'foldlen' by
2615              * how many bytes the current char occupies.  Only when it reaches
2616              * 0 do we increment 'minchars' or look for another multi-character
2617              * sequence. */
2618             if (folder == NULL) {
2619                 minchars++;
2620             }
2621             else if (foldlen > 0) {
2622                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2623             }
2624             else {
2625                 minchars++;
2626
2627                 /* See if *uc is the beginning of a multi-character fold.  If
2628                  * so, we decrement the length remaining to look at, to account
2629                  * for the current character this iteration.  (We can use 'uc'
2630                  * instead of the fold returned by TRIE_READ_CHAR because for
2631                  * non-UTF, the latin1_safe macro is smart enough to account
2632                  * for all the unfolded characters, and because for UTF, the
2633                  * string will already have been folded earlier in the
2634                  * compilation process */
2635                 if (UTF) {
2636                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2637                         foldlen -= UTF8SKIP(uc);
2638                     }
2639                 }
2640                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2641                     foldlen--;
2642                 }
2643             }
2644
2645             /* The current character (and any potential folds) should be added
2646              * to the possible matching characters for this position in this
2647              * branch */
2648             if ( uvc < 256 ) {
2649                 if ( folder ) {
2650                     U8 folded= folder[ (U8) uvc ];
2651                     if ( !trie->charmap[ folded ] ) {
2652                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2653                         TRIE_STORE_REVCHAR( folded );
2654                     }
2655                 }
2656                 if ( !trie->charmap[ uvc ] ) {
2657                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2658                     TRIE_STORE_REVCHAR( uvc );
2659                 }
2660                 if ( set_bit ) {
2661                     /* store the codepoint in the bitmap, and its folded
2662                      * equivalent. */
2663                     TRIE_BITMAP_SET(trie, uvc);
2664
2665                     /* store the folded codepoint */
2666                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
2667
2668                     if ( !UTF ) {
2669                         /* store first byte of utf8 representation of
2670                            variant codepoints */
2671                         if (! UVCHR_IS_INVARIANT(uvc)) {
2672                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
2673                         }
2674                     }
2675                     set_bit = 0; /* We've done our bit :-) */
2676                 }
2677             } else {
2678
2679                 /* XXX We could come up with the list of code points that fold
2680                  * to this using PL_utf8_foldclosures, except not for
2681                  * multi-char folds, as there may be multiple combinations
2682                  * there that could work, which needs to wait until runtime to
2683                  * resolve (The comment about LIGATURE FFI above is such an
2684                  * example */
2685
2686                 SV** svpp;
2687                 if ( !widecharmap )
2688                     widecharmap = newHV();
2689
2690                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2691
2692                 if ( !svpp )
2693                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
2694
2695                 if ( !SvTRUE( *svpp ) ) {
2696                     sv_setiv( *svpp, ++trie->uniquecharcount );
2697                     TRIE_STORE_REVCHAR(uvc);
2698                 }
2699             }
2700         } /* end loop through characters in this branch of the trie */
2701
2702         /* We take the min and max for this branch and combine to find the min
2703          * and max for all branches processed so far */
2704         if( cur == first ) {
2705             trie->minlen = minchars;
2706             trie->maxlen = maxchars;
2707         } else if (minchars < trie->minlen) {
2708             trie->minlen = minchars;
2709         } else if (maxchars > trie->maxlen) {
2710             trie->maxlen = maxchars;
2711         }
2712     } /* end first pass */
2713     DEBUG_TRIE_COMPILE_r(
2714         Perl_re_indentf( aTHX_
2715                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2716                 depth+1,
2717                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2718                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2719                 (int)trie->minlen, (int)trie->maxlen )
2720     );
2721
2722     /*
2723         We now know what we are dealing with in terms of unique chars and
2724         string sizes so we can calculate how much memory a naive
2725         representation using a flat table  will take. If it's over a reasonable
2726         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2727         conservative but potentially much slower representation using an array
2728         of lists.
2729
2730         At the end we convert both representations into the same compressed
2731         form that will be used in regexec.c for matching with. The latter
2732         is a form that cannot be used to construct with but has memory
2733         properties similar to the list form and access properties similar
2734         to the table form making it both suitable for fast searches and
2735         small enough that its feasable to store for the duration of a program.
2736
2737         See the comment in the code where the compressed table is produced
2738         inplace from the flat tabe representation for an explanation of how
2739         the compression works.
2740
2741     */
2742
2743
2744     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2745     prev_states[1] = 0;
2746
2747     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2748                                                     > SvIV(re_trie_maxbuff) )
2749     {
2750         /*
2751             Second Pass -- Array Of Lists Representation
2752
2753             Each state will be represented by a list of charid:state records
2754             (reg_trie_trans_le) the first such element holds the CUR and LEN
2755             points of the allocated array. (See defines above).
2756
2757             We build the initial structure using the lists, and then convert
2758             it into the compressed table form which allows faster lookups
2759             (but cant be modified once converted).
2760         */
2761
2762         STRLEN transcount = 1;
2763
2764         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2765             depth+1));
2766
2767         trie->states = (reg_trie_state *)
2768             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2769                                   sizeof(reg_trie_state) );
2770         TRIE_LIST_NEW(1);
2771         next_alloc = 2;
2772
2773         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2774
2775             regnode *noper   = NEXTOPER( cur );
2776             U32 state        = 1;         /* required init */
2777             U16 charid       = 0;         /* sanity init */
2778             U32 wordlen      = 0;         /* required init */
2779
2780             if (OP(noper) == NOTHING) {
2781                 regnode *noper_next= regnext(noper);
2782                 if (noper_next < tail)
2783                     noper= noper_next;
2784             }
2785
2786             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2787                 const U8 *uc= (U8*)STRING(noper);
2788                 const U8 *e= uc + STR_LEN(noper);
2789
2790                 for ( ; uc < e ; uc += len ) {
2791
2792                     TRIE_READ_CHAR;
2793
2794                     if ( uvc < 256 ) {
2795                         charid = trie->charmap[ uvc ];
2796                     } else {
2797                         SV** const svpp = hv_fetch( widecharmap,
2798                                                     (char*)&uvc,
2799                                                     sizeof( UV ),
2800                                                     0);
2801                         if ( !svpp ) {
2802                             charid = 0;
2803                         } else {
2804                             charid=(U16)SvIV( *svpp );
2805                         }
2806                     }
2807                     /* charid is now 0 if we dont know the char read, or
2808                      * nonzero if we do */
2809                     if ( charid ) {
2810
2811                         U16 check;
2812                         U32 newstate = 0;
2813
2814                         charid--;
2815                         if ( !trie->states[ state ].trans.list ) {
2816                             TRIE_LIST_NEW( state );
2817                         }
2818                         for ( check = 1;
2819                               check <= TRIE_LIST_USED( state );
2820                               check++ )
2821                         {
2822                             if ( TRIE_LIST_ITEM( state, check ).forid
2823                                                                     == charid )
2824                             {
2825                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2826                                 break;
2827                             }
2828                         }
2829                         if ( ! newstate ) {
2830                             newstate = next_alloc++;
2831                             prev_states[newstate] = state;
2832                             TRIE_LIST_PUSH( state, charid, newstate );
2833                             transcount++;
2834                         }
2835                         state = newstate;
2836                     } else {
2837                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2838                     }
2839                 }
2840             }
2841             TRIE_HANDLE_WORD(state);
2842
2843         } /* end second pass */
2844
2845         /* next alloc is the NEXT state to be allocated */
2846         trie->statecount = next_alloc;
2847         trie->states = (reg_trie_state *)
2848             PerlMemShared_realloc( trie->states,
2849                                    next_alloc
2850                                    * sizeof(reg_trie_state) );
2851
2852         /* and now dump it out before we compress it */
2853         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2854                                                          revcharmap, next_alloc,
2855                                                          depth+1)
2856         );
2857
2858         trie->trans = (reg_trie_trans *)
2859             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2860         {
2861             U32 state;
2862             U32 tp = 0;
2863             U32 zp = 0;
2864
2865
2866             for( state=1 ; state < next_alloc ; state ++ ) {
2867                 U32 base=0;
2868
2869                 /*
2870                 DEBUG_TRIE_COMPILE_MORE_r(
2871                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2872                 );
2873                 */
2874
2875                 if (trie->states[state].trans.list) {
2876                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2877                     U16 maxid=minid;
2878                     U16 idx;
2879
2880                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2881                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2882                         if ( forid < minid ) {
2883                             minid=forid;
2884                         } else if ( forid > maxid ) {
2885                             maxid=forid;
2886                         }
2887                     }
2888                     if ( transcount < tp + maxid - minid + 1) {
2889                         transcount *= 2;
2890                         trie->trans = (reg_trie_trans *)
2891                             PerlMemShared_realloc( trie->trans,
2892                                                      transcount
2893                                                      * sizeof(reg_trie_trans) );
2894                         Zero( trie->trans + (transcount / 2),
2895                               transcount / 2,
2896                               reg_trie_trans );
2897                     }
2898                     base = trie->uniquecharcount + tp - minid;
2899                     if ( maxid == minid ) {
2900                         U32 set = 0;
2901                         for ( ; zp < tp ; zp++ ) {
2902                             if ( ! trie->trans[ zp ].next ) {
2903                                 base = trie->uniquecharcount + zp - minid;
2904                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2905                                                                    1).newstate;
2906                                 trie->trans[ zp ].check = state;
2907                                 set = 1;
2908                                 break;
2909                             }
2910                         }
2911                         if ( !set ) {
2912                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2913                                                                    1).newstate;
2914                             trie->trans[ tp ].check = state;
2915                             tp++;
2916                             zp = tp;
2917                         }
2918                     } else {
2919                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2920                             const U32 tid = base
2921                                            - trie->uniquecharcount
2922                                            + TRIE_LIST_ITEM( state, idx ).forid;
2923                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2924                                                                 idx ).newstate;
2925                             trie->trans[ tid ].check = state;
2926                         }
2927                         tp += ( maxid - minid + 1 );
2928                     }
2929                     Safefree(trie->states[ state ].trans.list);
2930                 }
2931                 /*
2932                 DEBUG_TRIE_COMPILE_MORE_r(
2933                     Perl_re_printf( aTHX_  " base: %d\n",base);
2934                 );
2935                 */
2936                 trie->states[ state ].trans.base=base;
2937             }
2938             trie->lasttrans = tp + 1;
2939         }
2940     } else {
2941         /*
2942            Second Pass -- Flat Table Representation.
2943
2944            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2945            each.  We know that we will need Charcount+1 trans at most to store
2946            the data (one row per char at worst case) So we preallocate both
2947            structures assuming worst case.
2948
2949            We then construct the trie using only the .next slots of the entry
2950            structs.
2951
2952            We use the .check field of the first entry of the node temporarily
2953            to make compression both faster and easier by keeping track of how
2954            many non zero fields are in the node.
2955
2956            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2957            transition.
2958
2959            There are two terms at use here: state as a TRIE_NODEIDX() which is
2960            a number representing the first entry of the node, and state as a
2961            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2962            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2963            if there are 2 entrys per node. eg:
2964
2965              A B       A B
2966           1. 2 4    1. 3 7
2967           2. 0 3    3. 0 5
2968           3. 0 0    5. 0 0
2969           4. 0 0    7. 0 0
2970
2971            The table is internally in the right hand, idx form. However as we
2972            also have to deal with the states array which is indexed by nodenum
2973            we have to use TRIE_NODENUM() to convert.
2974
2975         */
2976         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
2977             depth+1));
2978
2979         trie->trans = (reg_trie_trans *)
2980             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2981                                   * trie->uniquecharcount + 1,
2982                                   sizeof(reg_trie_trans) );
2983         trie->states = (reg_trie_state *)
2984             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2985                                   sizeof(reg_trie_state) );
2986         next_alloc = trie->uniquecharcount + 1;
2987
2988
2989         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2990
2991             regnode *noper   = NEXTOPER( cur );
2992
2993             U32 state        = 1;         /* required init */
2994
2995             U16 charid       = 0;         /* sanity init */
2996             U32 accept_state = 0;         /* sanity init */
2997
2998             U32 wordlen      = 0;         /* required init */
2999
3000             if (OP(noper) == NOTHING) {
3001                 regnode *noper_next= regnext(noper);
3002                 if (noper_next < tail)
3003                     noper= noper_next;
3004             }
3005
3006             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3007                 const U8 *uc= (U8*)STRING(noper);
3008                 const U8 *e= uc + STR_LEN(noper);
3009
3010                 for ( ; uc < e ; uc += len ) {
3011
3012                     TRIE_READ_CHAR;
3013
3014                     if ( uvc < 256 ) {
3015                         charid = trie->charmap[ uvc ];
3016                     } else {
3017                         SV* const * const svpp = hv_fetch( widecharmap,
3018                                                            (char*)&uvc,
3019                                                            sizeof( UV ),
3020                                                            0);
3021                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3022                     }
3023                     if ( charid ) {
3024                         charid--;
3025                         if ( !trie->trans[ state + charid ].next ) {
3026                             trie->trans[ state + charid ].next = next_alloc;
3027                             trie->trans[ state ].check++;
3028                             prev_states[TRIE_NODENUM(next_alloc)]
3029                                     = TRIE_NODENUM(state);
3030                             next_alloc += trie->uniquecharcount;
3031                         }
3032                         state = trie->trans[ state + charid ].next;
3033                     } else {
3034                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
3035                     }
3036                     /* charid is now 0 if we dont know the char read, or
3037                      * nonzero if we do */
3038                 }
3039             }
3040             accept_state = TRIE_NODENUM( state );
3041             TRIE_HANDLE_WORD(accept_state);
3042
3043         } /* end second pass */
3044
3045         /* and now dump it out before we compress it */
3046         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3047                                                           revcharmap,
3048                                                           next_alloc, depth+1));
3049
3050         {
3051         /*
3052            * Inplace compress the table.*
3053
3054            For sparse data sets the table constructed by the trie algorithm will
3055            be mostly 0/FAIL transitions or to put it another way mostly empty.
3056            (Note that leaf nodes will not contain any transitions.)
3057
3058            This algorithm compresses the tables by eliminating most such
3059            transitions, at the cost of a modest bit of extra work during lookup:
3060
3061            - Each states[] entry contains a .base field which indicates the
3062            index in the state[] array wheres its transition data is stored.
3063
3064            - If .base is 0 there are no valid transitions from that node.
3065
3066            - If .base is nonzero then charid is added to it to find an entry in
3067            the trans array.
3068
3069            -If trans[states[state].base+charid].check!=state then the
3070            transition is taken to be a 0/Fail transition. Thus if there are fail
3071            transitions at the front of the node then the .base offset will point
3072            somewhere inside the previous nodes data (or maybe even into a node
3073            even earlier), but the .check field determines if the transition is
3074            valid.
3075
3076            XXX - wrong maybe?
3077            The following process inplace converts the table to the compressed
3078            table: We first do not compress the root node 1,and mark all its
3079            .check pointers as 1 and set its .base pointer as 1 as well. This
3080            allows us to do a DFA construction from the compressed table later,
3081            and ensures that any .base pointers we calculate later are greater
3082            than 0.
3083
3084            - We set 'pos' to indicate the first entry of the second node.
3085
3086            - We then iterate over the columns of the node, finding the first and
3087            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3088            and set the .check pointers accordingly, and advance pos
3089            appropriately and repreat for the next node. Note that when we copy
3090            the next pointers we have to convert them from the original
3091            NODEIDX form to NODENUM form as the former is not valid post
3092            compression.
3093
3094            - If a node has no transitions used we mark its base as 0 and do not
3095            advance the pos pointer.
3096
3097            - If a node only has one transition we use a second pointer into the
3098            structure to fill in allocated fail transitions from other states.
3099            This pointer is independent of the main pointer and scans forward
3100            looking for null transitions that are allocated to a state. When it
3101            finds one it writes the single transition into the "hole".  If the
3102            pointer doesnt find one the single transition is appended as normal.
3103
3104            - Once compressed we can Renew/realloc the structures to release the
3105            excess space.
3106
3107            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3108            specifically Fig 3.47 and the associated pseudocode.
3109
3110            demq
3111         */
3112         const U32 laststate = TRIE_NODENUM( next_alloc );
3113         U32 state, charid;
3114         U32 pos = 0, zp=0;
3115         trie->statecount = laststate;
3116
3117         for ( state = 1 ; state < laststate ; state++ ) {
3118             U8 flag = 0;
3119             const U32 stateidx = TRIE_NODEIDX( state );
3120             const U32 o_used = trie->trans[ stateidx ].check;
3121             U32 used = trie->trans[ stateidx ].check;
3122             trie->trans[ stateidx ].check = 0;
3123
3124             for ( charid = 0;
3125                   used && charid < trie->uniquecharcount;
3126                   charid++ )
3127             {
3128                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3129                     if ( trie->trans[ stateidx + charid ].next ) {
3130                         if (o_used == 1) {
3131                             for ( ; zp < pos ; zp++ ) {
3132                                 if ( ! trie->trans[ zp ].next ) {
3133                                     break;
3134                                 }
3135                             }
3136                             trie->states[ state ].trans.base
3137                                                     = zp
3138                                                       + trie->uniquecharcount
3139                                                       - charid ;
3140                             trie->trans[ zp ].next
3141                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3142                                                              + charid ].next );
3143                             trie->trans[ zp ].check = state;
3144                             if ( ++zp > pos ) pos = zp;
3145                             break;
3146                         }
3147                         used--;
3148                     }
3149                     if ( !flag ) {
3150                         flag = 1;
3151                         trie->states[ state ].trans.base
3152                                        = pos + trie->uniquecharcount - charid ;
3153                     }
3154                     trie->trans[ pos ].next
3155                         = SAFE_TRIE_NODENUM(
3156                                        trie->trans[ stateidx + charid ].next );
3157                     trie->trans[ pos ].check = state;
3158                     pos++;
3159                 }
3160             }
3161         }
3162         trie->lasttrans = pos + 1;
3163         trie->states = (reg_trie_state *)
3164             PerlMemShared_realloc( trie->states, laststate
3165                                    * sizeof(reg_trie_state) );
3166         DEBUG_TRIE_COMPILE_MORE_r(
3167             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
3168                 depth+1,
3169                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3170                        + 1 ),
3171                 (IV)next_alloc,
3172                 (IV)pos,
3173                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3174             );
3175
3176         } /* end table compress */
3177     }
3178     DEBUG_TRIE_COMPILE_MORE_r(
3179             Perl_re_indentf( aTHX_  "Statecount:%"UVxf" Lasttrans:%"UVxf"\n",
3180                 depth+1,
3181                 (UV)trie->statecount,
3182                 (UV)trie->lasttrans)
3183     );
3184     /* resize the trans array to remove unused space */
3185     trie->trans = (reg_trie_trans *)
3186         PerlMemShared_realloc( trie->trans, trie->lasttrans
3187                                * sizeof(reg_trie_trans) );
3188
3189     {   /* Modify the program and insert the new TRIE node */
3190         U8 nodetype =(U8)(flags & 0xFF);
3191         char *str=NULL;
3192
3193 #ifdef DEBUGGING
3194         regnode *optimize = NULL;
3195 #ifdef RE_TRACK_PATTERN_OFFSETS
3196
3197         U32 mjd_offset = 0;
3198         U32 mjd_nodelen = 0;
3199 #endif /* RE_TRACK_PATTERN_OFFSETS */
3200 #endif /* DEBUGGING */
3201         /*
3202            This means we convert either the first branch or the first Exact,
3203            depending on whether the thing following (in 'last') is a branch
3204            or not and whther first is the startbranch (ie is it a sub part of
3205            the alternation or is it the whole thing.)
3206            Assuming its a sub part we convert the EXACT otherwise we convert
3207            the whole branch sequence, including the first.
3208          */
3209         /* Find the node we are going to overwrite */
3210         if ( first != startbranch || OP( last ) == BRANCH ) {
3211             /* branch sub-chain */
3212             NEXT_OFF( first ) = (U16)(last - first);
3213 #ifdef RE_TRACK_PATTERN_OFFSETS
3214             DEBUG_r({
3215                 mjd_offset= Node_Offset((convert));
3216                 mjd_nodelen= Node_Length((convert));
3217             });
3218 #endif
3219             /* whole branch chain */
3220         }
3221 #ifdef RE_TRACK_PATTERN_OFFSETS
3222         else {
3223             DEBUG_r({
3224                 const  regnode *nop = NEXTOPER( convert );
3225                 mjd_offset= Node_Offset((nop));
3226                 mjd_nodelen= Node_Length((nop));
3227             });
3228         }
3229         DEBUG_OPTIMISE_r(
3230             Perl_re_indentf( aTHX_  "MJD offset:%"UVuf" MJD length:%"UVuf"\n",
3231                 depth+1,
3232                 (UV)mjd_offset, (UV)mjd_nodelen)
3233         );
3234 #endif
3235         /* But first we check to see if there is a common prefix we can
3236            split out as an EXACT and put in front of the TRIE node.  */
3237         trie->startstate= 1;
3238         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3239             U32 state;
3240             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3241                 U32 ofs = 0;
3242                 I32 idx = -1;
3243                 U32 count = 0;
3244                 const U32 base = trie->states[ state ].trans.base;
3245
3246                 if ( trie->states[state].wordnum )
3247                         count = 1;
3248
3249                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3250                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3251                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3252                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3253                     {
3254                         if ( ++count > 1 ) {
3255                             SV **tmp = av_fetch( revcharmap, ofs, 0);
3256                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
3257                             if ( state == 1 ) break;
3258                             if ( count == 2 ) {
3259                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3260                                 DEBUG_OPTIMISE_r(
3261                                     Perl_re_indentf( aTHX_  "New Start State=%"UVuf" Class: [",
3262                                         depth+1,
3263                                         (UV)state));
3264                                 if (idx >= 0) {
3265                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
3266                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3267
3268                                     TRIE_BITMAP_SET(trie,*ch);
3269                                     if ( folder )
3270                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
3271                                     DEBUG_OPTIMISE_r(
3272                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3273                                     );
3274                                 }
3275                             }
3276                             TRIE_BITMAP_SET(trie,*ch);
3277                             if ( folder )
3278                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
3279                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3280                         }
3281                         idx = ofs;
3282                     }
3283                 }
3284                 if ( count == 1 ) {
3285                     SV **tmp = av_fetch( revcharmap, idx, 0);
3286                     STRLEN len;
3287                     char *ch = SvPV( *tmp, len );
3288                     DEBUG_OPTIMISE_r({
3289                         SV *sv=sv_newmortal();
3290                         Perl_re_indentf( aTHX_  "Prefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
3291                             depth+1,
3292                             (UV)state, (UV)idx,
3293                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3294                                 PL_colors[0], PL_colors[1],
3295                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3296                                 PERL_PV_ESCAPE_FIRSTCHAR
3297                             )
3298                         );
3299                     });
3300                     if ( state==1 ) {
3301                         OP( convert ) = nodetype;
3302                         str=STRING(convert);
3303                         STR_LEN(convert)=0;
3304                     }
3305                     STR_LEN(convert) += len;
3306                     while (len--)
3307                         *str++ = *ch++;
3308                 } else {
3309 #ifdef DEBUGGING
3310                     if (state>1)
3311                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3312 #endif
3313                     break;
3314                 }
3315             }
3316             trie->prefixlen = (state-1);
3317             if (str) {
3318                 regnode *n = convert+NODE_SZ_STR(convert);
3319                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3320                 trie->startstate = state;
3321                 trie->minlen -= (state - 1);
3322                 trie->maxlen -= (state - 1);
3323 #ifdef DEBUGGING
3324                /* At least the UNICOS C compiler choked on this
3325                 * being argument to DEBUG_r(), so let's just have
3326                 * it right here. */
3327                if (
3328 #ifdef PERL_EXT_RE_BUILD
3329                    1
3330 #else
3331                    DEBUG_r_TEST
3332 #endif
3333                    ) {
3334                    regnode *fix = convert;
3335                    U32 word = trie->wordcount;
3336                    mjd_nodelen++;
3337                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3338                    while( ++fix < n ) {
3339                        Set_Node_Offset_Length(fix, 0, 0);
3340                    }
3341                    while (word--) {
3342                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3343                        if (tmp) {
3344                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3345                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3346                            else
3347                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3348                        }
3349                    }
3350                }
3351 #endif
3352                 if (trie->maxlen) {
3353                     convert = n;
3354                 } else {
3355                     NEXT_OFF(convert) = (U16)(tail - convert);
3356                     DEBUG_r(optimize= n);
3357                 }
3358             }
3359         }
3360         if (!jumper)
3361             jumper = last;
3362         if ( trie->maxlen ) {
3363             NEXT_OFF( convert ) = (U16)(tail - convert);
3364             ARG_SET( convert, data_slot );
3365             /* Store the offset to the first unabsorbed branch in
3366                jump[0], which is otherwise unused by the jump logic.
3367                We use this when dumping a trie and during optimisation. */
3368             if (trie->jump)
3369                 trie->jump[0] = (U16)(nextbranch - convert);
3370
3371             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3372              *   and there is a bitmap
3373              *   and the first "jump target" node we found leaves enough room
3374              * then convert the TRIE node into a TRIEC node, with the bitmap
3375              * embedded inline in the opcode - this is hypothetically faster.
3376              */
3377             if ( !trie->states[trie->startstate].wordnum
3378                  && trie->bitmap
3379                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3380             {
3381                 OP( convert ) = TRIEC;
3382                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3383                 PerlMemShared_free(trie->bitmap);
3384                 trie->bitmap= NULL;
3385             } else
3386                 OP( convert ) = TRIE;
3387
3388             /* store the type in the flags */
3389             convert->flags = nodetype;
3390             DEBUG_r({
3391             optimize = convert
3392                       + NODE_STEP_REGNODE
3393                       + regarglen[ OP( convert ) ];
3394             });
3395             /* XXX We really should free up the resource in trie now,
3396                    as we won't use them - (which resources?) dmq */
3397         }
3398         /* needed for dumping*/
3399         DEBUG_r(if (optimize) {
3400             regnode *opt = convert;
3401
3402             while ( ++opt < optimize) {
3403                 Set_Node_Offset_Length(opt,0,0);
3404             }
3405             /*
3406                 Try to clean up some of the debris left after the
3407                 optimisation.
3408              */
3409             while( optimize < jumper ) {
3410                 mjd_nodelen += Node_Length((optimize));
3411                 OP( optimize ) = OPTIMIZED;
3412                 Set_Node_Offset_Length(optimize,0,0);
3413                 optimize++;
3414             }
3415             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3416         });
3417     } /* end node insert */
3418
3419     /*  Finish populating the prev field of the wordinfo array.  Walk back
3420      *  from each accept state until we find another accept state, and if
3421      *  so, point the first word's .prev field at the second word. If the
3422      *  second already has a .prev field set, stop now. This will be the
3423      *  case either if we've already processed that word's accept state,
3424      *  or that state had multiple words, and the overspill words were
3425      *  already linked up earlier.
3426      */
3427     {
3428         U16 word;
3429         U32 state;
3430         U16 prev;
3431
3432         for (word=1; word <= trie->wordcount; word++) {
3433             prev = 0;
3434             if (trie->wordinfo[word].prev)
3435                 continue;
3436             state = trie->wordinfo[word].accept;
3437             while (state) {
3438                 state = prev_states[state];
3439                 if (!state)
3440                     break;
3441                 prev = trie->states[state].wordnum;
3442                 if (prev)
3443                     break;
3444             }
3445             trie->wordinfo[word].prev = prev;
3446         }
3447         Safefree(prev_states);
3448     }
3449
3450
3451     /* and now dump out the compressed format */
3452     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3453
3454     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3455 #ifdef DEBUGGING
3456     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3457     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3458 #else
3459     SvREFCNT_dec_NN(revcharmap);
3460 #endif
3461     return trie->jump
3462            ? MADE_JUMP_TRIE
3463            : trie->startstate>1
3464              ? MADE_EXACT_TRIE
3465              : MADE_TRIE;
3466 }
3467
3468 STATIC regnode *
3469 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3470 {
3471 /* The Trie is constructed and compressed now so we can build a fail array if
3472  * it's needed
3473
3474    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3475    3.32 in the
3476    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3477    Ullman 1985/88
3478    ISBN 0-201-10088-6
3479
3480    We find the fail state for each state in the trie, this state is the longest
3481    proper suffix of the current state's 'word' that is also a proper prefix of
3482    another word in our trie. State 1 represents the word '' and is thus the
3483    default fail state. This allows the DFA not to have to restart after its
3484    tried and failed a word at a given point, it simply continues as though it
3485    had been matching the other word in the first place.
3486    Consider
3487       'abcdgu'=~/abcdefg|cdgu/
3488    When we get to 'd' we are still matching the first word, we would encounter
3489    'g' which would fail, which would bring us to the state representing 'd' in
3490    the second word where we would try 'g' and succeed, proceeding to match
3491    'cdgu'.
3492  */
3493  /* add a fail transition */
3494     const U32 trie_offset = ARG(source);
3495     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3496     U32 *q;
3497     const U32 ucharcount = trie->uniquecharcount;
3498     const U32 numstates = trie->statecount;
3499     const U32 ubound = trie->lasttrans + ucharcount;
3500     U32 q_read = 0;
3501     U32 q_write = 0;
3502     U32 charid;
3503     U32 base = trie->states[ 1 ].trans.base;
3504     U32 *fail;
3505     reg_ac_data *aho;
3506     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3507     regnode *stclass;
3508     GET_RE_DEBUG_FLAGS_DECL;
3509
3510     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3511     PERL_UNUSED_CONTEXT;
3512 #ifndef DEBUGGING
3513     PERL_UNUSED_ARG(depth);
3514 #endif
3515
3516     if ( OP(source) == TRIE ) {
3517         struct regnode_1 *op = (struct regnode_1 *)
3518             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3519         StructCopy(source,op,struct regnode_1);
3520         stclass = (regnode *)op;
3521     } else {
3522         struct regnode_charclass *op = (struct regnode_charclass *)
3523             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3524         StructCopy(source,op,struct regnode_charclass);
3525         stclass = (regnode *)op;
3526     }
3527     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3528
3529     ARG_SET( stclass, data_slot );
3530     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3531     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3532     aho->trie=trie_offset;
3533     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3534     Copy( trie->states, aho->states, numstates, reg_trie_state );
3535     Newxz( q, numstates, U32);
3536     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3537     aho->refcount = 1;
3538     fail = aho->fail;
3539     /* initialize fail[0..1] to be 1 so that we always have
3540        a valid final fail state */
3541     fail[ 0 ] = fail[ 1 ] = 1;
3542
3543     for ( charid = 0; charid < ucharcount ; charid++ ) {
3544         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3545         if ( newstate ) {
3546             q[ q_write ] = newstate;
3547             /* set to point at the root */
3548             fail[ q[ q_write++ ] ]=1;
3549         }
3550     }
3551     while ( q_read < q_write) {
3552         const U32 cur = q[ q_read++ % numstates ];
3553         base = trie->states[ cur ].trans.base;
3554
3555         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3556             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3557             if (ch_state) {
3558                 U32 fail_state = cur;
3559                 U32 fail_base;
3560                 do {
3561                     fail_state = fail[ fail_state ];
3562                     fail_base = aho->states[ fail_state ].trans.base;
3563                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3564
3565                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3566                 fail[ ch_state ] = fail_state;
3567                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3568                 {
3569                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3570                 }
3571                 q[ q_write++ % numstates] = ch_state;
3572             }
3573         }
3574     }
3575     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3576        when we fail in state 1, this allows us to use the
3577        charclass scan to find a valid start char. This is based on the principle
3578        that theres a good chance the string being searched contains lots of stuff
3579        that cant be a start char.
3580      */
3581     fail[ 0 ] = fail[ 1 ] = 0;
3582     DEBUG_TRIE_COMPILE_r({
3583         Perl_re_indentf( aTHX_  "Stclass Failtable (%"UVuf" states): 0",
3584                       depth, (UV)numstates
3585         );
3586         for( q_read=1; q_read<numstates; q_read++ ) {
3587             Perl_re_printf( aTHX_  ", %"UVuf, (UV)fail[q_read]);
3588         }
3589         Perl_re_printf( aTHX_  "\n");
3590     });
3591     Safefree(q);
3592     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3593     return stclass;
3594 }
3595
3596
3597 #define DEBUG_PEEP(str,scan,depth)         \
3598     DEBUG_OPTIMISE_r({if (scan){           \
3599        regnode *Next = regnext(scan);      \
3600        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);\
3601        Perl_re_indentf( aTHX_  "" str ">%3d: %s (%d)", \
3602            depth, REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3603            Next ? (REG_NODE_NUM(Next)) : 0 );\
3604        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3605        Perl_re_printf( aTHX_  "\n");                   \
3606    }});
3607
3608 /* The below joins as many adjacent EXACTish nodes as possible into a single
3609  * one.  The regop may be changed if the node(s) contain certain sequences that
3610  * require special handling.  The joining is only done if:
3611  * 1) there is room in the current conglomerated node to entirely contain the
3612  *    next one.
3613  * 2) they are the exact same node type
3614  *
3615  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3616  * these get optimized out
3617  *
3618  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3619  * as possible, even if that means splitting an existing node so that its first
3620  * part is moved to the preceeding node.  This would maximise the efficiency of
3621  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3622  * EXACTFish nodes into portions that don't change under folding vs those that
3623  * do.  Those portions that don't change may be the only things in the pattern that
3624  * could be used to find fixed and floating strings.
3625  *
3626  * If a node is to match under /i (folded), the number of characters it matches
3627  * can be different than its character length if it contains a multi-character
3628  * fold.  *min_subtract is set to the total delta number of characters of the
3629  * input nodes.
3630  *
3631  * And *unfolded_multi_char is set to indicate whether or not the node contains
3632  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3633  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3634  * SMALL LETTER SHARP S, as only if the target string being matched against
3635  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3636  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3637  * whose components are all above the Latin1 range are not run-time locale
3638  * dependent, and have already been folded by the time this function is
3639  * called.)
3640  *
3641  * This is as good a place as any to discuss the design of handling these
3642  * multi-character fold sequences.  It's been wrong in Perl for a very long
3643  * time.  There are three code points in Unicode whose multi-character folds
3644  * were long ago discovered to mess things up.  The previous designs for
3645  * dealing with these involved assigning a special node for them.  This
3646  * approach doesn't always work, as evidenced by this example:
3647  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3648  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3649  * would match just the \xDF, it won't be able to handle the case where a
3650  * successful match would have to cross the node's boundary.  The new approach
3651  * that hopefully generally solves the problem generates an EXACTFU_SS node
3652  * that is "sss" in this case.
3653  *
3654  * It turns out that there are problems with all multi-character folds, and not
3655  * just these three.  Now the code is general, for all such cases.  The
3656  * approach taken is:
3657  * 1)   This routine examines each EXACTFish node that could contain multi-
3658  *      character folded sequences.  Since a single character can fold into
3659  *      such a sequence, the minimum match length for this node is less than
3660  *      the number of characters in the node.  This routine returns in
3661  *      *min_subtract how many characters to subtract from the the actual
3662  *      length of the string to get a real minimum match length; it is 0 if
3663  *      there are no multi-char foldeds.  This delta is used by the caller to
3664  *      adjust the min length of the match, and the delta between min and max,
3665  *      so that the optimizer doesn't reject these possibilities based on size
3666  *      constraints.
3667  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3668  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3669  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3670  *      there is a possible fold length change.  That means that a regular
3671  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3672  *      with length changes, and so can be processed faster.  regexec.c takes
3673  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3674  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3675  *      known until runtime).  This saves effort in regex matching.  However,
3676  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3677  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3678  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3679  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3680  *      possibilities for the non-UTF8 patterns are quite simple, except for
3681  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3682  *      members of a fold-pair, and arrays are set up for all of them so that
3683  *      the other member of the pair can be found quickly.  Code elsewhere in
3684  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3685  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3686  *      described in the next item.
3687  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3688  *      validity of the fold won't be known until runtime, and so must remain
3689  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3690  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3691  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3692  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3693  *      The reason this is a problem is that the optimizer part of regexec.c
3694  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3695  *      that a character in the pattern corresponds to at most a single
3696  *      character in the target string.  (And I do mean character, and not byte
3697  *      here, unlike other parts of the documentation that have never been
3698  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3699  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3700  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3701  *      nodes, violate the assumption, and they are the only instances where it
3702  *      is violated.  I'm reluctant to try to change the assumption, as the
3703  *      code involved is impenetrable to me (khw), so instead the code here
3704  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3705  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3706  *      boolean indicating whether or not the node contains such a fold.  When
3707  *      it is true, the caller sets a flag that later causes the optimizer in
3708  *      this file to not set values for the floating and fixed string lengths,
3709  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3710  *      assumption.  Thus, there is no optimization based on string lengths for
3711  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3712  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3713  *      assumption is wrong only in these cases is that all other non-UTF-8
3714  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3715  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3716  *      EXACTF nodes because we don't know at compile time if it actually
3717  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3718  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3719  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3720  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3721  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3722  *      string would require the pattern to be forced into UTF-8, the overhead
3723  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3724  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3725  *      locale.)
3726  *
3727  *      Similarly, the code that generates tries doesn't currently handle
3728  *      not-already-folded multi-char folds, and it looks like a pain to change
3729  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3730  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3731  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3732  *      using /iaa matching will be doing so almost entirely with ASCII
3733  *      strings, so this should rarely be encountered in practice */
3734
3735 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3736     if (PL_regkind[OP(scan)] == EXACT) \
3737         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3738
3739 STATIC U32
3740 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3741                    UV *min_subtract, bool *unfolded_multi_char,
3742                    U32 flags,regnode *val, U32 depth)
3743 {
3744     /* Merge several consecutive EXACTish nodes into one. */
3745     regnode *n = regnext(scan);
3746     U32 stringok = 1;
3747     regnode *next = scan + NODE_SZ_STR(scan);
3748     U32 merged = 0;
3749     U32 stopnow = 0;
3750 #ifdef DEBUGGING
3751     regnode *stop = scan;
3752     GET_RE_DEBUG_FLAGS_DECL;
3753 #else
3754     PERL_UNUSED_ARG(depth);
3755 #endif
3756
3757     PERL_ARGS_ASSERT_JOIN_EXACT;
3758 #ifndef EXPERIMENTAL_INPLACESCAN
3759     PERL_UNUSED_ARG(flags);
3760     PERL_UNUSED_ARG(val);
3761 #endif
3762     DEBUG_PEEP("join",scan,depth);
3763
3764     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3765      * EXACT ones that are mergeable to the current one. */
3766     while (n
3767            && (PL_regkind[OP(n)] == NOTHING
3768                || (stringok && OP(n) == OP(scan)))
3769            && NEXT_OFF(n)
3770            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3771     {
3772
3773         if (OP(n) == TAIL || n > next)
3774             stringok = 0;
3775         if (PL_regkind[OP(n)] == NOTHING) {
3776             DEBUG_PEEP("skip:",n,depth);
3777             NEXT_OFF(scan) += NEXT_OFF(n);
3778             next = n + NODE_STEP_REGNODE;
3779 #ifdef DEBUGGING
3780             if (stringok)
3781                 stop = n;
3782 #endif
3783             n = regnext(n);
3784         }
3785         else if (stringok) {
3786             const unsigned int oldl = STR_LEN(scan);
3787             regnode * const nnext = regnext(n);
3788
3789             /* XXX I (khw) kind of doubt that this works on platforms (should
3790              * Perl ever run on one) where U8_MAX is above 255 because of lots
3791              * of other assumptions */
3792             /* Don't join if the sum can't fit into a single node */
3793             if (oldl + STR_LEN(n) > U8_MAX)
3794                 break;
3795
3796             DEBUG_PEEP("merg",n,depth);
3797             merged++;
3798
3799             NEXT_OFF(scan) += NEXT_OFF(n);
3800             STR_LEN(scan) += STR_LEN(n);
3801             next = n + NODE_SZ_STR(n);
3802             /* Now we can overwrite *n : */
3803             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3804 #ifdef DEBUGGING
3805             stop = next - 1;
3806 #endif
3807             n = nnext;
3808             if (stopnow) break;
3809         }
3810
3811 #ifdef EXPERIMENTAL_INPLACESCAN
3812         if (flags && !NEXT_OFF(n)) {
3813             DEBUG_PEEP("atch", val, depth);
3814             if (reg_off_by_arg[OP(n)]) {
3815                 ARG_SET(n, val - n);
3816             }
3817             else {
3818                 NEXT_OFF(n) = val - n;
3819             }
3820             stopnow = 1;
3821         }
3822 #endif
3823     }
3824
3825     *min_subtract = 0;
3826     *unfolded_multi_char = FALSE;
3827
3828     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3829      * can now analyze for sequences of problematic code points.  (Prior to
3830      * this final joining, sequences could have been split over boundaries, and
3831      * hence missed).  The sequences only happen in folding, hence for any
3832      * non-EXACT EXACTish node */
3833     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3834         U8* s0 = (U8*) STRING(scan);
3835         U8* s = s0;
3836         U8* s_end = s0 + STR_LEN(scan);
3837
3838         int total_count_delta = 0;  /* Total delta number of characters that
3839                                        multi-char folds expand to */
3840
3841         /* One pass is made over the node's string looking for all the
3842          * possibilities.  To avoid some tests in the loop, there are two main
3843          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3844          * non-UTF-8 */
3845         if (UTF) {
3846             U8* folded = NULL;
3847
3848             if (OP(scan) == EXACTFL) {
3849                 U8 *d;
3850
3851                 /* An EXACTFL node would already have been changed to another
3852                  * node type unless there is at least one character in it that
3853                  * is problematic; likely a character whose fold definition
3854                  * won't be known until runtime, and so has yet to be folded.
3855                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3856                  * to handle the UTF-8 case, we need to create a temporary
3857                  * folded copy using UTF-8 locale rules in order to analyze it.
3858                  * This is because our macros that look to see if a sequence is
3859                  * a multi-char fold assume everything is folded (otherwise the
3860                  * tests in those macros would be too complicated and slow).
3861                  * Note that here, the non-problematic folds will have already
3862                  * been done, so we can just copy such characters.  We actually
3863                  * don't completely fold the EXACTFL string.  We skip the
3864                  * unfolded multi-char folds, as that would just create work
3865                  * below to figure out the size they already are */
3866
3867                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3868                 d = folded;
3869                 while (s < s_end) {
3870                     STRLEN s_len = UTF8SKIP(s);
3871                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3872                         Copy(s, d, s_len, U8);
3873                         d += s_len;
3874                     }
3875                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3876                         *unfolded_multi_char = TRUE;
3877                         Copy(s, d, s_len, U8);
3878                         d += s_len;
3879                     }
3880                     else if (isASCII(*s)) {
3881                         *(d++) = toFOLD(*s);
3882                     }
3883                     else {
3884                         STRLEN len;
3885                         _to_utf8_fold_flags(s, d, &len, FOLD_FLAGS_FULL);
3886                         d += len;
3887                     }
3888                     s += s_len;
3889                 }
3890
3891                 /* Point the remainder of the routine to look at our temporary
3892                  * folded copy */
3893                 s = folded;
3894                 s_end = d;
3895             } /* End of creating folded copy of EXACTFL string */
3896
3897             /* Examine the string for a multi-character fold sequence.  UTF-8
3898              * patterns have all characters pre-folded by the time this code is
3899              * executed */
3900             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3901                                      length sequence we are looking for is 2 */
3902             {
3903                 int count = 0;  /* How many characters in a multi-char fold */
3904                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3905                 if (! len) {    /* Not a multi-char fold: get next char */
3906                     s += UTF8SKIP(s);
3907                     continue;
3908                 }
3909
3910                 /* Nodes with 'ss' require special handling, except for
3911                  * EXACTFA-ish for which there is no multi-char fold to this */
3912                 if (len == 2 && *s == 's' && *(s+1) == 's'
3913                     && OP(scan) != EXACTFA
3914                     && OP(scan) != EXACTFA_NO_TRIE)
3915                 {
3916                     count = 2;
3917                     if (OP(scan) != EXACTFL) {
3918                         OP(scan) = EXACTFU_SS;
3919                     }
3920                     s += 2;
3921                 }
3922                 else { /* Here is a generic multi-char fold. */
3923                     U8* multi_end  = s + len;
3924
3925                     /* Count how many characters are in it.  In the case of
3926                      * /aa, no folds which contain ASCII code points are
3927                      * allowed, so check for those, and skip if found. */
3928                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3929                         count = utf8_length(s, multi_end);
3930                         s = multi_end;
3931                     }
3932                     else {
3933                         while (s < multi_end) {
3934                             if (isASCII(*s)) {
3935                                 s++;
3936                                 goto next_iteration;
3937                             }
3938                             else {
3939                                 s += UTF8SKIP(s);
3940                             }
3941                             count++;
3942                         }
3943                     }
3944                 }
3945
3946                 /* The delta is how long the sequence is minus 1 (1 is how long
3947                  * the character that folds to the sequence is) */
3948                 total_count_delta += count - 1;
3949               next_iteration: ;
3950             }
3951
3952             /* We created a temporary folded copy of the string in EXACTFL
3953              * nodes.  Therefore we need to be sure it doesn't go below zero,
3954              * as the real string could be shorter */
3955             if (OP(scan) == EXACTFL) {
3956                 int total_chars = utf8_length((U8*) STRING(scan),
3957                                            (U8*) STRING(scan) + STR_LEN(scan));
3958                 if (total_count_delta > total_chars) {
3959                     total_count_delta = total_chars;
3960                 }
3961             }
3962
3963             *min_subtract += total_count_delta;
3964             Safefree(folded);
3965         }
3966         else if (OP(scan) == EXACTFA) {
3967
3968             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3969              * fold to the ASCII range (and there are no existing ones in the
3970              * upper latin1 range).  But, as outlined in the comments preceding
3971              * this function, we need to flag any occurrences of the sharp s.
3972              * This character forbids trie formation (because of added
3973              * complexity) */
3974 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
3975    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
3976                                       || UNICODE_DOT_DOT_VERSION > 0)
3977             while (s < s_end) {
3978                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3979                     OP(scan) = EXACTFA_NO_TRIE;
3980                     *unfolded_multi_char = TRUE;
3981                     break;
3982                 }
3983                 s++;
3984             }
3985         }
3986         else {
3987
3988             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
3989              * folds that are all Latin1.  As explained in the comments
3990              * preceding this function, we look also for the sharp s in EXACTF
3991              * and EXACTFL nodes; it can be in the final position.  Otherwise
3992              * we can stop looking 1 byte earlier because have to find at least
3993              * two characters for a multi-fold */
3994             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
3995                               ? s_end
3996                               : s_end -1;
3997
3998             while (s < upper) {
3999                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4000                 if (! len) {    /* Not a multi-char fold. */
4001                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4002                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4003                     {
4004                         *unfolded_multi_char = TRUE;
4005                     }
4006                     s++;
4007                     continue;
4008                 }
4009
4010                 if (len == 2
4011                     && isALPHA_FOLD_EQ(*s, 's')
4012                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4013                 {
4014
4015                     /* EXACTF nodes need to know that the minimum length
4016                      * changed so that a sharp s in the string can match this
4017                      * ss in the pattern, but they remain EXACTF nodes, as they
4018                      * won't match this unless the target string is is UTF-8,
4019                      * which we don't know until runtime.  EXACTFL nodes can't
4020                      * transform into EXACTFU nodes */
4021                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4022                         OP(scan) = EXACTFU_SS;
4023                     }
4024                 }
4025
4026                 *min_subtract += len - 1;
4027                 s += len;
4028             }
4029 #endif
4030         }
4031     }
4032
4033 #ifdef DEBUGGING
4034     /* Allow dumping but overwriting the collection of skipped
4035      * ops and/or strings with fake optimized ops */
4036     n = scan + NODE_SZ_STR(scan);
4037     while (n <= stop) {
4038         OP(n) = OPTIMIZED;
4039         FLAGS(n) = 0;
4040         NEXT_OFF(n) = 0;
4041         n++;
4042     }
4043 #endif
4044     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
4045     return stopnow;
4046 }
4047
4048 /* REx optimizer.  Converts nodes into quicker variants "in place".
4049    Finds fixed substrings.  */
4050
4051 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4052    to the position after last scanned or to NULL. */
4053
4054 #define INIT_AND_WITHP \
4055     assert(!and_withp); \
4056     Newx(and_withp,1, regnode_ssc); \
4057     SAVEFREEPV(and_withp)
4058
4059
4060 static void
4061 S_unwind_scan_frames(pTHX_ const void *p)
4062 {
4063     scan_frame *f= (scan_frame *)p;
4064     do {
4065         scan_frame *n= f->next_frame;
4066         Safefree(f);
4067         f= n;
4068     } while (f);
4069 }
4070
4071
4072 STATIC SSize_t
4073 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4074                         SSize_t *minlenp, SSize_t *deltap,
4075                         regnode *last,
4076                         scan_data_t *data,
4077                         I32 stopparen,
4078                         U32 recursed_depth,
4079                         regnode_ssc *and_withp,
4080                         U32 flags, U32 depth)
4081                         /* scanp: Start here (read-write). */
4082                         /* deltap: Write maxlen-minlen here. */
4083                         /* last: Stop before this one. */
4084                         /* data: string data about the pattern */
4085                         /* stopparen: treat close N as END */
4086                         /* recursed: which subroutines have we recursed into */
4087                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4088 {
4089     /* There must be at least this number of characters to match */
4090     SSize_t min = 0;
4091     I32 pars = 0, code;
4092     regnode *scan = *scanp, *next;
4093     SSize_t delta = 0;
4094     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4095     int is_inf_internal = 0;            /* The studied chunk is infinite */
4096     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4097     scan_data_t data_fake;
4098     SV *re_trie_maxbuff = NULL;
4099     regnode *first_non_open = scan;
4100     SSize_t stopmin = SSize_t_MAX;
4101     scan_frame *frame = NULL;
4102     GET_RE_DEBUG_FLAGS_DECL;
4103
4104     PERL_ARGS_ASSERT_STUDY_CHUNK;
4105
4106
4107     if ( depth == 0 ) {
4108         while (first_non_open && OP(first_non_open) == OPEN)
4109             first_non_open=regnext(first_non_open);
4110     }
4111
4112
4113   fake_study_recurse:
4114     DEBUG_r(
4115         RExC_study_chunk_recursed_count++;
4116     );
4117     DEBUG_OPTIMISE_MORE_r(
4118     {
4119         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4120             depth, (long)stopparen,
4121             (unsigned long)RExC_study_chunk_recursed_count,
4122             (unsigned long)depth, (unsigned long)recursed_depth,
4123             scan,
4124             last);
4125         if (recursed_depth) {
4126             U32 i;
4127             U32 j;
4128             for ( j = 0 ; j < recursed_depth ; j++ ) {
4129                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4130                     if (
4131                         PAREN_TEST(RExC_study_chunk_recursed +
4132                                    ( j * RExC_study_chunk_recursed_bytes), i )
4133                         && (
4134                             !j ||
4135                             !PAREN_TEST(RExC_study_chunk_recursed +
4136                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4137                         )
4138                     ) {
4139                         Perl_re_printf( aTHX_ " %d",(int)i);
4140                         break;
4141                     }
4142                 }
4143                 if ( j + 1 < recursed_depth ) {
4144                     Perl_re_printf( aTHX_  ",");
4145                 }
4146             }
4147         }
4148         Perl_re_printf( aTHX_ "\n");
4149     }
4150     );
4151     while ( scan && OP(scan) != END && scan < last ){
4152         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4153                                    node length to get a real minimum (because
4154                                    the folded version may be shorter) */
4155         bool unfolded_multi_char = FALSE;
4156         /* Peephole optimizer: */
4157         DEBUG_STUDYDATA("Peep:", data, depth);
4158         DEBUG_PEEP("Peep", scan, depth);
4159
4160
4161         /* The reason we do this here is that we need to deal with things like
4162          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4163          * parsing code, as each (?:..) is handled by a different invocation of
4164          * reg() -- Yves
4165          */
4166         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4167
4168         /* Follow the next-chain of the current node and optimize
4169            away all the NOTHINGs from it.  */
4170         if (OP(scan) != CURLYX) {
4171             const int max = (reg_off_by_arg[OP(scan)]
4172                        ? I32_MAX
4173                        /* I32 may be smaller than U16 on CRAYs! */
4174                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4175             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4176             int noff;
4177             regnode *n = scan;
4178
4179             /* Skip NOTHING and LONGJMP. */
4180             while ((n = regnext(n))
4181                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4182                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4183                    && off + noff < max)
4184                 off += noff;
4185             if (reg_off_by_arg[OP(scan)])
4186                 ARG(scan) = off;
4187             else
4188                 NEXT_OFF(scan) = off;
4189         }
4190
4191         /* The principal pseudo-switch.  Cannot be a switch, since we
4192            look into several different things.  */
4193         if ( OP(scan) == DEFINEP ) {
4194             SSize_t minlen = 0;
4195             SSize_t deltanext = 0;
4196             SSize_t fake_last_close = 0;
4197             I32 f = SCF_IN_DEFINE;
4198
4199             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4200             scan = regnext(scan);
4201             assert( OP(scan) == IFTHEN );
4202             DEBUG_PEEP("expect IFTHEN", scan, depth);
4203
4204             data_fake.last_closep= &fake_last_close;
4205             minlen = *minlenp;
4206             next = regnext(scan);
4207             scan = NEXTOPER(NEXTOPER(scan));
4208             DEBUG_PEEP("scan", scan, depth);
4209             DEBUG_PEEP("next", next, depth);
4210
4211             /* we suppose the run is continuous, last=next...
4212              * NOTE we dont use the return here! */
4213             (void)study_chunk(pRExC_state, &scan, &minlen,
4214                               &deltanext, next, &data_fake, stopparen,
4215                               recursed_depth, NULL, f, depth+1);
4216
4217             scan = next;
4218         } else
4219         if (
4220             OP(scan) == BRANCH  ||
4221             OP(scan) == BRANCHJ ||
4222             OP(scan) == IFTHEN
4223         ) {
4224             next = regnext(scan);
4225             code = OP(scan);
4226
4227             /* The op(next)==code check below is to see if we
4228              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4229              * IFTHEN is special as it might not appear in pairs.
4230              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4231              * we dont handle it cleanly. */
4232             if (OP(next) == code || code == IFTHEN) {
4233                 /* NOTE - There is similar code to this block below for
4234                  * handling TRIE nodes on a re-study.  If you change stuff here
4235                  * check there too. */
4236                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4237                 regnode_ssc accum;
4238                 regnode * const startbranch=scan;
4239
4240                 if (flags & SCF_DO_SUBSTR) {
4241                     /* Cannot merge strings after this. */
4242                     scan_commit(pRExC_state, data, minlenp, is_inf);
4243                 }
4244
4245                 if (flags & SCF_DO_STCLASS)
4246                     ssc_init_zero(pRExC_state, &accum);
4247
4248                 while (OP(scan) == code) {
4249                     SSize_t deltanext, minnext, fake;
4250                     I32 f = 0;
4251                     regnode_ssc this_class;
4252
4253                     DEBUG_PEEP("Branch", scan, depth);
4254
4255                     num++;
4256                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4257                     if (data) {
4258                         data_fake.whilem_c = data->whilem_c;
4259                         data_fake.last_closep = data->last_closep;
4260                     }
4261                     else
4262                         data_fake.last_closep = &fake;
4263
4264                     data_fake.pos_delta = delta;
4265                     next = regnext(scan);
4266
4267                     scan = NEXTOPER(scan); /* everything */
4268                     if (code != BRANCH)    /* everything but BRANCH */
4269                         scan = NEXTOPER(scan);
4270
4271                     if (flags & SCF_DO_STCLASS) {
4272                         ssc_init(pRExC_state, &this_class);
4273                         data_fake.start_class = &this_class;
4274                         f = SCF_DO_STCLASS_AND;
4275                     }
4276                     if (flags & SCF_WHILEM_VISITED_POS)
4277                         f |= SCF_WHILEM_VISITED_POS;
4278
4279                     /* we suppose the run is continuous, last=next...*/
4280                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4281                                       &deltanext, next, &data_fake, stopparen,
4282                                       recursed_depth, NULL, f,depth+1);
4283
4284                     if (min1 > minnext)
4285                         min1 = minnext;
4286                     if (deltanext == SSize_t_MAX) {
4287                         is_inf = is_inf_internal = 1;
4288                         max1 = SSize_t_MAX;
4289                     } else if (max1 < minnext + deltanext)
4290                         max1 = minnext + deltanext;
4291                     scan = next;
4292                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4293                         pars++;
4294                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4295                         if ( stopmin > minnext)
4296                             stopmin = min + min1;
4297                         flags &= ~SCF_DO_SUBSTR;
4298                         if (data)
4299                             data->flags |= SCF_SEEN_ACCEPT;
4300                     }
4301                     if (data) {
4302                         if (data_fake.flags & SF_HAS_EVAL)
4303                             data->flags |= SF_HAS_EVAL;
4304                         data->whilem_c = data_fake.whilem_c;
4305                     }
4306                     if (flags & SCF_DO_STCLASS)
4307                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4308                 }
4309                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4310                     min1 = 0;
4311                 if (flags & SCF_DO_SUBSTR) {
4312                     data->pos_min += min1;
4313                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4314                         data->pos_delta = SSize_t_MAX;
4315                     else
4316                         data->pos_delta += max1 - min1;
4317                     if (max1 != min1 || is_inf)
4318                         data->longest = &(data->longest_float);
4319                 }
4320                 min += min1;
4321                 if (delta == SSize_t_MAX
4322                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4323                     delta = SSize_t_MAX;
4324                 else
4325                     delta += max1 - min1;
4326                 if (flags & SCF_DO_STCLASS_OR) {
4327                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4328                     if (min1) {
4329                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4330                         flags &= ~SCF_DO_STCLASS;
4331                     }
4332                 }
4333                 else if (flags & SCF_DO_STCLASS_AND) {
4334                     if (min1) {
4335                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4336                         flags &= ~SCF_DO_STCLASS;
4337                     }
4338                     else {
4339                         /* Switch to OR mode: cache the old value of
4340                          * data->start_class */
4341                         INIT_AND_WITHP;
4342                         StructCopy(data->start_class, and_withp, regnode_ssc);
4343                         flags &= ~SCF_DO_STCLASS_AND;
4344                         StructCopy(&accum, data->start_class, regnode_ssc);
4345                         flags |= SCF_DO_STCLASS_OR;
4346                     }
4347                 }
4348
4349                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4350                         OP( startbranch ) == BRANCH )
4351                 {
4352                 /* demq.
4353
4354                    Assuming this was/is a branch we are dealing with: 'scan'
4355                    now points at the item that follows the branch sequence,
4356                    whatever it is. We now start at the beginning of the
4357                    sequence and look for subsequences of
4358
4359                    BRANCH->EXACT=>x1
4360                    BRANCH->EXACT=>x2
4361                    tail
4362
4363                    which would be constructed from a pattern like
4364                    /A|LIST|OF|WORDS/
4365
4366                    If we can find such a subsequence we need to turn the first
4367                    element into a trie and then add the subsequent branch exact
4368                    strings to the trie.
4369
4370                    We have two cases
4371
4372                      1. patterns where the whole set of branches can be
4373                         converted.
4374
4375                      2. patterns where only a subset can be converted.
4376
4377                    In case 1 we can replace the whole set with a single regop
4378                    for the trie. In case 2 we need to keep the start and end
4379                    branches so
4380
4381                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4382                      becomes BRANCH TRIE; BRANCH X;
4383
4384                   There is an additional case, that being where there is a
4385                   common prefix, which gets split out into an EXACT like node
4386                   preceding the TRIE node.
4387
4388                   If x(1..n)==tail then we can do a simple trie, if not we make
4389                   a "jump" trie, such that when we match the appropriate word
4390                   we "jump" to the appropriate tail node. Essentially we turn
4391                   a nested if into a case structure of sorts.
4392
4393                 */
4394
4395                     int made=0;
4396                     if (!re_trie_maxbuff) {
4397                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4398                         if (!SvIOK(re_trie_maxbuff))
4399                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4400                     }
4401                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4402                         regnode *cur;
4403                         regnode *first = (regnode *)NULL;
4404                         regnode *last = (regnode *)NULL;
4405                         regnode *tail = scan;
4406                         U8 trietype = 0;
4407                         U32 count=0;
4408
4409                         /* var tail is used because there may be a TAIL
4410                            regop in the way. Ie, the exacts will point to the
4411                            thing following the TAIL, but the last branch will
4412                            point at the TAIL. So we advance tail. If we
4413                            have nested (?:) we may have to move through several
4414                            tails.
4415                          */
4416
4417                         while ( OP( tail ) == TAIL ) {
4418                             /* this is the TAIL generated by (?:) */
4419                             tail = regnext( tail );
4420                         }
4421
4422
4423                         DEBUG_TRIE_COMPILE_r({
4424                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4425                             Perl_re_indentf( aTHX_  "%s %"UVuf":%s\n",
4426                               depth+1,
4427                               "Looking for TRIE'able sequences. Tail node is ",
4428                               (UV)(tail - RExC_emit_start),
4429                               SvPV_nolen_const( RExC_mysv )
4430                             );
4431                         });
4432
4433                         /*
4434
4435                             Step through the branches
4436                                 cur represents each branch,
4437                                 noper is the first thing to be matched as part
4438                                       of that branch
4439                                 noper_next is the regnext() of that node.
4440
4441                             We normally handle a case like this
4442                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4443                             support building with NOJUMPTRIE, which restricts
4444                             the trie logic to structures like /FOO|BAR/.
4445
4446                             If noper is a trieable nodetype then the branch is
4447                             a possible optimization target. If we are building
4448                             under NOJUMPTRIE then we require that noper_next is
4449                             the same as scan (our current position in the regex
4450                             program).
4451
4452                             Once we have two or more consecutive such branches
4453                             we can create a trie of the EXACT's contents and
4454                             stitch it in place into the program.
4455
4456                             If the sequence represents all of the branches in
4457                             the alternation we replace the entire thing with a
4458                             single TRIE node.
4459
4460                             Otherwise when it is a subsequence we need to
4461                             stitch it in place and replace only the relevant
4462                             branches. This means the first branch has to remain
4463                             as it is used by the alternation logic, and its
4464                             next pointer, and needs to be repointed at the item
4465                             on the branch chain following the last branch we
4466                             have optimized away.
4467
4468                             This could be either a BRANCH, in which case the
4469                             subsequence is internal, or it could be the item
4470                             following the branch sequence in which case the
4471                             subsequence is at the end (which does not
4472                             necessarily mean the first node is the start of the
4473                             alternation).
4474
4475                             TRIE_TYPE(X) is a define which maps the optype to a
4476                             trietype.
4477
4478                                 optype          |  trietype
4479                                 ----------------+-----------
4480                                 NOTHING         | NOTHING
4481                                 EXACT           | EXACT
4482                                 EXACTFU         | EXACTFU
4483                                 EXACTFU_SS      | EXACTFU
4484                                 EXACTFA         | EXACTFA
4485                                 EXACTL          | EXACTL
4486                                 EXACTFLU8       | EXACTFLU8
4487
4488
4489                         */
4490 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4491                        ? NOTHING                                            \
4492                        : ( EXACT == (X) )                                   \
4493                          ? EXACT                                            \
4494                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4495                            ? EXACTFU                                        \
4496                            : ( EXACTFA == (X) )                             \
4497                              ? EXACTFA                                      \
4498                              : ( EXACTL == (X) )                            \
4499                                ? EXACTL                                     \
4500                                : ( EXACTFLU8 == (X) )                        \
4501                                  ? EXACTFLU8                                 \
4502                                  : 0 )
4503
4504                         /* dont use tail as the end marker for this traverse */
4505                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4506                             regnode * const noper = NEXTOPER( cur );
4507                             U8 noper_type = OP( noper );
4508                             U8 noper_trietype = TRIE_TYPE( noper_type );
4509 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4510                             regnode * const noper_next = regnext( noper );
4511                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4512                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4513 #endif
4514
4515                             DEBUG_TRIE_COMPILE_r({
4516                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4517                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4518                                    depth+1,
4519                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4520
4521                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4522                                 Perl_re_printf( aTHX_  " -> %d:%s",
4523                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4524
4525                                 if ( noper_next ) {
4526                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4527                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4528                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4529                                 }
4530                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4531                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4532                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4533                                 );
4534                             });
4535
4536                             /* Is noper a trieable nodetype that can be merged
4537                              * with the current trie (if there is one)? */
4538                             if ( noper_trietype
4539                                   &&
4540                                   (
4541                                         ( noper_trietype == NOTHING )
4542                                         || ( trietype == NOTHING )
4543                                         || ( trietype == noper_trietype )
4544                                   )
4545 #ifdef NOJUMPTRIE
4546                                   && noper_next >= tail
4547 #endif
4548                                   && count < U16_MAX)
4549                             {
4550                                 /* Handle mergable triable node Either we are
4551                                  * the first node in a new trieable sequence,
4552                                  * in which case we do some bookkeeping,
4553                                  * otherwise we update the end pointer. */
4554                                 if ( !first ) {
4555                                     first = cur;
4556                                     if ( noper_trietype == NOTHING ) {
4557 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4558                                         regnode * const noper_next = regnext( noper );
4559                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4560                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4561 #endif
4562
4563                                         if ( noper_next_trietype ) {
4564                                             trietype = noper_next_trietype;
4565                                         } else if (noper_next_type)  {
4566                                             /* a NOTHING regop is 1 regop wide.
4567                                              * We need at least two for a trie
4568                                              * so we can't merge this in */
4569                                             first = NULL;
4570                                         }
4571                                     } else {
4572                                         trietype = noper_trietype;
4573                                     }
4574                                 } else {
4575                                     if ( trietype == NOTHING )
4576                                         trietype = noper_trietype;
4577                                     last = cur;
4578                                 }
4579                                 if (first)
4580                                     count++;
4581                             } /* end handle mergable triable node */
4582                             else {
4583                                 /* handle unmergable node -
4584                                  * noper may either be a triable node which can
4585                                  * not be tried together with the current trie,
4586                                  * or a non triable node */
4587                                 if ( last ) {
4588                                     /* If last is set and trietype is not
4589                                      * NOTHING then we have found at least two
4590                                      * triable branch sequences in a row of a
4591                                      * similar trietype so we can turn them
4592                                      * into a trie. If/when we allow NOTHING to
4593                                      * start a trie sequence this condition
4594                                      * will be required, and it isn't expensive
4595                                      * so we leave it in for now. */
4596                                     if ( trietype && trietype != NOTHING )
4597                                         make_trie( pRExC_state,
4598                                                 startbranch, first, cur, tail,
4599                                                 count, trietype, depth+1 );
4600                                     last = NULL; /* note: we clear/update
4601                                                     first, trietype etc below,
4602                                                     so we dont do it here */
4603                                 }
4604                                 if ( noper_trietype
4605 #ifdef NOJUMPTRIE
4606                                      && noper_next >= tail
4607 #endif
4608                                 ){
4609                                     /* noper is triable, so we can start a new
4610                                      * trie sequence */
4611                                     count = 1;
4612                                     first = cur;
4613                                     trietype = noper_trietype;
4614                                 } else if (first) {
4615                                     /* if we already saw a first but the
4616                                      * current node is not triable then we have
4617                                      * to reset the first information. */
4618                                     count = 0;
4619                                     first = NULL;
4620                                     trietype = 0;
4621                                 }
4622                             } /* end handle unmergable node */
4623                         } /* loop over branches */
4624                         DEBUG_TRIE_COMPILE_r({
4625                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4626                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4627                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4628                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4629                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4630                                PL_reg_name[trietype]
4631                             );
4632
4633                         });
4634                         if ( last && trietype ) {
4635                             if ( trietype != NOTHING ) {
4636                                 /* the last branch of the sequence was part of
4637                                  * a trie, so we have to construct it here
4638                                  * outside of the loop */
4639                                 made= make_trie( pRExC_state, startbranch,
4640                                                  first, scan, tail, count,
4641                                                  trietype, depth+1 );
4642 #ifdef TRIE_STUDY_OPT
4643                                 if ( ((made == MADE_EXACT_TRIE &&
4644                                      startbranch == first)
4645                                      || ( first_non_open == first )) &&
4646                                      depth==0 ) {
4647                                     flags |= SCF_TRIE_RESTUDY;
4648                                     if ( startbranch == first
4649                                          && scan >= tail )
4650                                     {
4651                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4652                                     }
4653                                 }
4654 #endif
4655                             } else {
4656                                 /* at this point we know whatever we have is a
4657                                  * NOTHING sequence/branch AND if 'startbranch'
4658                                  * is 'first' then we can turn the whole thing
4659                                  * into a NOTHING
4660                                  */
4661                                 if ( startbranch == first ) {
4662                                     regnode *opt;
4663                                     /* the entire thing is a NOTHING sequence,
4664                                      * something like this: (?:|) So we can
4665                                      * turn it into a plain NOTHING op. */
4666                                     DEBUG_TRIE_COMPILE_r({
4667                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4668                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4669                                           depth+1,
4670                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4671
4672                                     });
4673                                     OP(startbranch)= NOTHING;
4674                                     NEXT_OFF(startbranch)= tail - startbranch;
4675                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4676                                         OP(opt)= OPTIMIZED;
4677                                 }
4678                             }
4679                         } /* end if ( last) */
4680                     } /* TRIE_MAXBUF is non zero */
4681
4682                 } /* do trie */
4683
4684             }
4685             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4686                 scan = NEXTOPER(NEXTOPER(scan));
4687             } else                      /* single branch is optimized. */
4688                 scan = NEXTOPER(scan);
4689             continue;
4690         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4691             I32 paren = 0;
4692             regnode *start = NULL;
4693             regnode *end = NULL;
4694             U32 my_recursed_depth= recursed_depth;
4695
4696             if (OP(scan) != SUSPEND) { /* GOSUB */
4697                 /* Do setup, note this code has side effects beyond
4698                  * the rest of this block. Specifically setting
4699                  * RExC_recurse[] must happen at least once during
4700                  * study_chunk(). */
4701                 paren = ARG(scan);
4702                 RExC_recurse[ARG2L(scan)] = scan;
4703                 start = RExC_open_parens[paren];
4704                 end   = RExC_close_parens[paren];
4705
4706                 /* NOTE we MUST always execute the above code, even
4707                  * if we do nothing with a GOSUB */
4708                 if (
4709                     ( flags & SCF_IN_DEFINE )
4710                     ||
4711                     (
4712                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4713                         &&
4714                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4715                     )
4716                 ) {
4717                     /* no need to do anything here if we are in a define. */
4718                     /* or we are after some kind of infinite construct
4719                      * so we can skip recursing into this item.
4720                      * Since it is infinite we will not change the maxlen
4721                      * or delta, and if we miss something that might raise
4722                      * the minlen it will merely pessimise a little.
4723                      *
4724                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4725                      * might result in a minlen of 1 and not of 4,
4726                      * but this doesn't make us mismatch, just try a bit
4727                      * harder than we should.
4728                      * */
4729                     scan= regnext(scan);
4730                     continue;
4731                 }
4732
4733                 if (
4734                     !recursed_depth
4735                     ||
4736                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4737                 ) {
4738                     /* it is quite possible that there are more efficient ways
4739                      * to do this. We maintain a bitmap per level of recursion
4740                      * of which patterns we have entered so we can detect if a
4741                      * pattern creates a possible infinite loop. When we
4742                      * recurse down a level we copy the previous levels bitmap
4743                      * down. When we are at recursion level 0 we zero the top
4744                      * level bitmap. It would be nice to implement a different
4745                      * more efficient way of doing this. In particular the top
4746                      * level bitmap may be unnecessary.
4747                      */
4748                     if (!recursed_depth) {
4749                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4750                     } else {
4751                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4752                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4753                              RExC_study_chunk_recursed_bytes, U8);
4754                     }
4755                     /* we havent recursed into this paren yet, so recurse into it */
4756                     DEBUG_STUDYDATA("gosub-set:", data,depth);
4757                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4758                     my_recursed_depth= recursed_depth + 1;
4759                 } else {
4760                     DEBUG_STUDYDATA("gosub-inf:", data,depth);
4761                     /* some form of infinite recursion, assume infinite length
4762                      * */
4763                     if (flags & SCF_DO_SUBSTR) {
4764                         scan_commit(pRExC_state, data, minlenp, is_inf);
4765                         data->longest = &(data->longest_float);
4766                     }
4767                     is_inf = is_inf_internal = 1;
4768                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4769                         ssc_anything(data->start_class);
4770                     flags &= ~SCF_DO_STCLASS;
4771
4772                     start= NULL; /* reset start so we dont recurse later on. */
4773                 }
4774             } else {
4775                 paren = stopparen;
4776                 start = scan + 2;
4777                 end = regnext(scan);
4778             }
4779             if (start) {
4780                 scan_frame *newframe;
4781                 assert(end);
4782                 if (!RExC_frame_last) {
4783                     Newxz(newframe, 1, scan_frame);
4784                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4785                     RExC_frame_head= newframe;
4786                     RExC_frame_count++;
4787                 } else if (!RExC_frame_last->next_frame) {
4788                     Newxz(newframe,1,scan_frame);
4789                     RExC_frame_last->next_frame= newframe;
4790                     newframe->prev_frame= RExC_frame_last;
4791                     RExC_frame_count++;
4792                 } else {
4793                     newframe= RExC_frame_last->next_frame;
4794                 }
4795                 RExC_frame_last= newframe;
4796
4797                 newframe->next_regnode = regnext(scan);
4798                 newframe->last_regnode = last;
4799                 newframe->stopparen = stopparen;
4800                 newframe->prev_recursed_depth = recursed_depth;
4801                 newframe->this_prev_frame= frame;
4802
4803                 DEBUG_STUDYDATA("frame-new:",data,depth);
4804                 DEBUG_PEEP("fnew", scan, depth);
4805
4806                 frame = newframe;
4807                 scan =  start;
4808                 stopparen = paren;
4809                 last = end;
4810                 depth = depth + 1;
4811                 recursed_depth= my_recursed_depth;
4812
4813                 continue;
4814             }
4815         }
4816         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4817             SSize_t l = STR_LEN(scan);
4818             UV uc;
4819             if (UTF) {
4820                 const U8 * const s = (U8*)STRING(scan);
4821                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4822                 l = utf8_length(s, s + l);
4823             } else {
4824                 uc = *((U8*)STRING(scan));
4825             }
4826             min += l;
4827             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4828                 /* The code below prefers earlier match for fixed
4829                    offset, later match for variable offset.  */
4830                 if (data->last_end == -1) { /* Update the start info. */
4831                     data->last_start_min = data->pos_min;
4832                     data->last_start_max = is_inf
4833                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4834                 }
4835                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4836                 if (UTF)
4837                     SvUTF8_on(data->last_found);
4838                 {
4839                     SV * const sv = data->last_found;
4840                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4841                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4842                     if (mg && mg->mg_len >= 0)
4843                         mg->mg_len += utf8_length((U8*)STRING(scan),
4844                                               (U8*)STRING(scan)+STR_LEN(scan));
4845                 }
4846                 data->last_end = data->pos_min + l;
4847                 data->pos_min += l; /* As in the first entry. */
4848                 data->flags &= ~SF_BEFORE_EOL;
4849             }
4850
4851             /* ANDing the code point leaves at most it, and not in locale, and
4852              * can't match null string */
4853             if (flags & SCF_DO_STCLASS_AND) {
4854                 ssc_cp_and(data->start_class, uc);
4855                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4856                 ssc_clear_locale(data->start_class);
4857             }
4858             else if (flags & SCF_DO_STCLASS_OR) {
4859                 ssc_add_cp(data->start_class, uc);
4860                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4861
4862                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4863                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4864             }
4865             flags &= ~SCF_DO_STCLASS;
4866         }
4867         else if (PL_regkind[OP(scan)] == EXACT) {
4868             /* But OP != EXACT!, so is EXACTFish */
4869             SSize_t l = STR_LEN(scan);
4870             const U8 * s = (U8*)STRING(scan);
4871
4872             /* Search for fixed substrings supports EXACT only. */
4873             if (flags & SCF_DO_SUBSTR) {
4874                 assert(data);
4875                 scan_commit(pRExC_state, data, minlenp, is_inf);
4876             }
4877             if (UTF) {
4878                 l = utf8_length(s, s + l);
4879             }
4880             if (unfolded_multi_char) {
4881                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4882             }
4883             min += l - min_subtract;
4884             assert (min >= 0);
4885             delta += min_subtract;
4886             if (flags & SCF_DO_SUBSTR) {
4887                 data->pos_min += l - min_subtract;
4888                 if (data->pos_min < 0) {
4889                     data->pos_min = 0;
4890                 }
4891                 data->pos_delta += min_subtract;
4892                 if (min_subtract) {
4893                     data->longest = &(data->longest_float);
4894                 }
4895             }
4896
4897             if (flags & SCF_DO_STCLASS) {
4898                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4899
4900                 assert(EXACTF_invlist);
4901                 if (flags & SCF_DO_STCLASS_AND) {
4902                     if (OP(scan) != EXACTFL)
4903                         ssc_clear_locale(data->start_class);
4904                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4905                     ANYOF_POSIXL_ZERO(data->start_class);
4906                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4907                 }
4908                 else {  /* SCF_DO_STCLASS_OR */
4909                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4910                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4911
4912                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4913                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4914                 }
4915                 flags &= ~SCF_DO_STCLASS;
4916                 SvREFCNT_dec(EXACTF_invlist);
4917             }
4918         }
4919         else if (REGNODE_VARIES(OP(scan))) {
4920             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4921             I32 fl = 0, f = flags;
4922             regnode * const oscan = scan;
4923             regnode_ssc this_class;
4924             regnode_ssc *oclass = NULL;
4925             I32 next_is_eval = 0;
4926
4927             switch (PL_regkind[OP(scan)]) {
4928             case WHILEM:                /* End of (?:...)* . */
4929                 scan = NEXTOPER(scan);
4930                 goto finish;
4931             case PLUS:
4932                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4933                     next = NEXTOPER(scan);
4934                     if (OP(next) == EXACT
4935                         || OP(next) == EXACTL
4936                         || (flags & SCF_DO_STCLASS))
4937                     {
4938                         mincount = 1;
4939                         maxcount = REG_INFTY;
4940                         next = regnext(scan);
4941                         scan = NEXTOPER(scan);
4942                         goto do_curly;
4943                     }
4944                 }
4945                 if (flags & SCF_DO_SUBSTR)
4946                     data->pos_min++;
4947                 min++;
4948                 /* FALLTHROUGH */
4949             case STAR:
4950                 if (flags & SCF_DO_STCLASS) {
4951                     mincount = 0;
4952                     maxcount = REG_INFTY;
4953                     next = regnext(scan);
4954                     scan = NEXTOPER(scan);
4955                     goto do_curly;
4956                 }
4957                 if (flags & SCF_DO_SUBSTR) {
4958                     scan_commit(pRExC_state, data, minlenp, is_inf);
4959                     /* Cannot extend fixed substrings */
4960                     data->longest = &(data->longest_float);
4961                 }
4962                 is_inf = is_inf_internal = 1;
4963                 scan = regnext(scan);
4964                 goto optimize_curly_tail;
4965             case CURLY:
4966                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4967                     && (scan->flags == stopparen))
4968                 {
4969                     mincount = 1;
4970                     maxcount = 1;
4971                 } else {
4972                     mincount = ARG1(scan);
4973                     maxcount = ARG2(scan);
4974                 }
4975                 next = regnext(scan);
4976                 if (OP(scan) == CURLYX) {
4977                     I32 lp = (data ? *(data->last_closep) : 0);
4978                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
4979                 }
4980                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4981                 next_is_eval = (OP(scan) == EVAL);
4982               do_curly:
4983                 if (flags & SCF_DO_SUBSTR) {
4984                     if (mincount == 0)
4985                         scan_commit(pRExC_state, data, minlenp, is_inf);
4986                     /* Cannot extend fixed substrings */
4987                     pos_before = data->pos_min;
4988                 }
4989                 if (data) {
4990                     fl = data->flags;
4991                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
4992                     if (is_inf)
4993                         data->flags |= SF_IS_INF;
4994                 }
4995                 if (flags & SCF_DO_STCLASS) {
4996                     ssc_init(pRExC_state, &this_class);
4997                     oclass = data->start_class;
4998                     data->start_class = &this_class;
4999                     f |= SCF_DO_STCLASS_AND;
5000                     f &= ~SCF_DO_STCLASS_OR;
5001                 }
5002                 /* Exclude from super-linear cache processing any {n,m}
5003                    regops for which the combination of input pos and regex
5004                    pos is not enough information to determine if a match
5005                    will be possible.
5006
5007                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5008                    regex pos at the \s*, the prospects for a match depend not
5009                    only on the input position but also on how many (bar\s*)
5010                    repeats into the {4,8} we are. */
5011                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5012                     f &= ~SCF_WHILEM_VISITED_POS;
5013
5014                 /* This will finish on WHILEM, setting scan, or on NULL: */
5015                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5016                                   last, data, stopparen, recursed_depth, NULL,
5017                                   (mincount == 0
5018                                    ? (f & ~SCF_DO_SUBSTR)
5019                                    : f)
5020                                   ,depth+1);
5021
5022                 if (flags & SCF_DO_STCLASS)
5023                     data->start_class = oclass;
5024                 if (mincount == 0 || minnext == 0) {
5025                     if (flags & SCF_DO_STCLASS_OR) {
5026                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5027                     }
5028                     else if (flags & SCF_DO_STCLASS_AND) {
5029                         /* Switch to OR mode: cache the old value of
5030                          * data->start_class */
5031                         INIT_AND_WITHP;
5032                         StructCopy(data->start_class, and_withp, regnode_ssc);
5033                         flags &= ~SCF_DO_STCLASS_AND;
5034                         StructCopy(&this_class, data->start_class, regnode_ssc);
5035                         flags |= SCF_DO_STCLASS_OR;
5036                         ANYOF_FLAGS(data->start_class)
5037                                                 |= SSC_MATCHES_EMPTY_STRING;
5038                     }
5039                 } else {                /* Non-zero len */
5040                     if (flags & SCF_DO_STCLASS_OR) {
5041                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5042                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5043                     }
5044                     else if (flags & SCF_DO_STCLASS_AND)
5045                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5046                     flags &= ~SCF_DO_STCLASS;
5047                 }
5048                 if (!scan)              /* It was not CURLYX, but CURLY. */
5049                     scan = next;
5050                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
5051                     /* ? quantifier ok, except for (?{ ... }) */
5052                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5053                     && (minnext == 0) && (deltanext == 0)
5054                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5055                     && maxcount <= REG_INFTY/3) /* Complement check for big
5056                                                    count */
5057                 {
5058                     /* Fatal warnings may leak the regexp without this: */
5059                     SAVEFREESV(RExC_rx_sv);
5060                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5061                         "Quantifier unexpected on zero-length expression "
5062                         "in regex m/%"UTF8f"/",
5063                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5064                                   RExC_precomp));
5065                     (void)ReREFCNT_inc(RExC_rx_sv);
5066                 }
5067
5068                 min += minnext * mincount;
5069                 is_inf_internal |= deltanext == SSize_t_MAX
5070                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5071                 is_inf |= is_inf_internal;
5072                 if (is_inf) {
5073                     delta = SSize_t_MAX;
5074                 } else {
5075                     delta += (minnext + deltanext) * maxcount
5076                              - minnext * mincount;
5077                 }
5078                 /* Try powerful optimization CURLYX => CURLYN. */
5079                 if (  OP(oscan) == CURLYX && data
5080                       && data->flags & SF_IN_PAR
5081                       && !(data->flags & SF_HAS_EVAL)
5082                       && !deltanext && minnext == 1 ) {
5083                     /* Try to optimize to CURLYN.  */
5084                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5085                     regnode * const nxt1 = nxt;
5086 #ifdef DEBUGGING
5087                     regnode *nxt2;
5088 #endif
5089
5090                     /* Skip open. */
5091                     nxt = regnext(nxt);
5092                     if (!REGNODE_SIMPLE(OP(nxt))
5093                         && !(PL_regkind[OP(nxt)] == EXACT
5094                              && STR_LEN(nxt) == 1))
5095                         goto nogo;
5096 #ifdef DEBUGGING
5097                     nxt2 = nxt;
5098 #endif
5099                     nxt = regnext(nxt);
5100                     if (OP(nxt) != CLOSE)
5101                         goto nogo;
5102                     if (RExC_open_parens) {
5103                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5104                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5105                     }
5106                     /* Now we know that nxt2 is the only contents: */
5107                     oscan->flags = (U8)ARG(nxt);
5108                     OP(oscan) = CURLYN;
5109                     OP(nxt1) = NOTHING; /* was OPEN. */
5110
5111 #ifdef DEBUGGING
5112                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5113                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5114                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5115                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5116                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5117                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5118 #endif
5119                 }
5120               nogo:
5121
5122                 /* Try optimization CURLYX => CURLYM. */
5123                 if (  OP(oscan) == CURLYX && data
5124                       && !(data->flags & SF_HAS_PAR)
5125                       && !(data->flags & SF_HAS_EVAL)
5126                       && !deltanext     /* atom is fixed width */
5127                       && minnext != 0   /* CURLYM can't handle zero width */
5128
5129                          /* Nor characters whose fold at run-time may be
5130                           * multi-character */
5131                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5132                 ) {
5133                     /* XXXX How to optimize if data == 0? */
5134                     /* Optimize to a simpler form.  */
5135                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5136                     regnode *nxt2;
5137
5138                     OP(oscan) = CURLYM;
5139                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5140                             && (OP(nxt2) != WHILEM))
5141                         nxt = nxt2;
5142                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5143                     /* Need to optimize away parenths. */
5144                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5145                         /* Set the parenth number.  */
5146                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5147
5148                         oscan->flags = (U8)ARG(nxt);
5149                         if (RExC_open_parens) {
5150                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5151                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5152                         }
5153                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5154                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5155
5156 #ifdef DEBUGGING
5157                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5158                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5159                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5160                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5161 #endif
5162 #if 0
5163                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5164                             regnode *nnxt = regnext(nxt1);
5165                             if (nnxt == nxt) {
5166                                 if (reg_off_by_arg[OP(nxt1)])
5167                                     ARG_SET(nxt1, nxt2 - nxt1);
5168                                 else if (nxt2 - nxt1 < U16_MAX)
5169                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5170                                 else
5171                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5172                             }
5173                             nxt1 = nnxt;
5174                         }
5175 #endif
5176                         /* Optimize again: */
5177                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5178                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5179                     }
5180                     else
5181                         oscan->flags = 0;
5182                 }
5183                 else if ((OP(oscan) == CURLYX)
5184                          && (flags & SCF_WHILEM_VISITED_POS)
5185                          /* See the comment on a similar expression above.
5186                             However, this time it's not a subexpression
5187                             we care about, but the expression itself. */
5188                          && (maxcount == REG_INFTY)
5189                          && data && ++data->whilem_c < 16) {
5190                     /* This stays as CURLYX, we can put the count/of pair. */
5191                     /* Find WHILEM (as in regexec.c) */
5192                     regnode *nxt = oscan + NEXT_OFF(oscan);
5193
5194                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5195                         nxt += ARG(nxt);
5196                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
5197                         | (RExC_whilem_seen << 4)); /* On WHILEM */
5198                 }
5199                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5200                     pars++;
5201                 if (flags & SCF_DO_SUBSTR) {
5202                     SV *last_str = NULL;
5203                     STRLEN last_chrs = 0;
5204                     int counted = mincount != 0;
5205
5206                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5207                                                                   string. */
5208                         SSize_t b = pos_before >= data->last_start_min
5209                             ? pos_before : data->last_start_min;
5210                         STRLEN l;
5211                         const char * const s = SvPV_const(data->last_found, l);
5212                         SSize_t old = b - data->last_start_min;
5213
5214                         if (UTF)
5215                             old = utf8_hop((U8*)s, old) - (U8*)s;
5216                         l -= old;
5217                         /* Get the added string: */
5218                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5219                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5220                                             (U8*)(s + old + l)) : l;
5221                         if (deltanext == 0 && pos_before == b) {
5222                             /* What was added is a constant string */
5223                             if (mincount > 1) {
5224
5225                                 SvGROW(last_str, (mincount * l) + 1);
5226                                 repeatcpy(SvPVX(last_str) + l,
5227                                           SvPVX_const(last_str), l,
5228                                           mincount - 1);
5229                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5230                                 /* Add additional parts. */
5231                                 SvCUR_set(data->last_found,
5232                                           SvCUR(data->last_found) - l);
5233                                 sv_catsv(data->last_found, last_str);
5234                                 {
5235                                     SV * sv = data->last_found;
5236                                     MAGIC *mg =
5237                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5238                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5239                                     if (mg && mg->mg_len >= 0)
5240                                         mg->mg_len += last_chrs * (mincount-1);
5241                                 }
5242                                 last_chrs *= mincount;
5243                                 data->last_end += l * (mincount - 1);
5244                             }
5245                         } else {
5246                             /* start offset must point into the last copy */
5247                             data->last_start_min += minnext * (mincount - 1);
5248                             data->last_start_max =
5249                               is_inf
5250                                ? SSize_t_MAX
5251                                : data->last_start_max +
5252                                  (maxcount - 1) * (minnext + data->pos_delta);
5253                         }
5254                     }
5255                     /* It is counted once already... */
5256                     data->pos_min += minnext * (mincount - counted);
5257 #if 0
5258 Perl_re_printf( aTHX_  "counted=%"UVuf" deltanext=%"UVuf
5259                               " SSize_t_MAX=%"UVuf" minnext=%"UVuf
5260                               " maxcount=%"UVuf" mincount=%"UVuf"\n",
5261     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5262     (UV)mincount);
5263 if (deltanext != SSize_t_MAX)
5264 Perl_re_printf( aTHX_  "LHS=%"UVuf" RHS=%"UVuf"\n",
5265     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5266           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5267 #endif
5268                     if (deltanext == SSize_t_MAX
5269                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5270                         data->pos_delta = SSize_t_MAX;
5271                     else
5272                         data->pos_delta += - counted * deltanext +
5273                         (minnext + deltanext) * maxcount - minnext * mincount;
5274                     if (mincount != maxcount) {
5275                          /* Cannot extend fixed substrings found inside
5276                             the group.  */
5277                         scan_commit(pRExC_state, data, minlenp, is_inf);
5278                         if (mincount && last_str) {
5279                             SV * const sv = data->last_found;
5280                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5281                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5282
5283                             if (mg)
5284                                 mg->mg_len = -1;
5285                             sv_setsv(sv, last_str);
5286                             data->last_end = data->pos_min;
5287                             data->last_start_min = data->pos_min - last_chrs;
5288                             data->last_start_max = is_inf
5289                                 ? SSize_t_MAX
5290                                 : data->pos_min + data->pos_delta - last_chrs;
5291                         }
5292                         data->longest = &(data->longest_float);
5293                     }
5294                     SvREFCNT_dec(last_str);
5295                 }
5296                 if (data && (fl & SF_HAS_EVAL))
5297                     data->flags |= SF_HAS_EVAL;
5298               optimize_curly_tail:
5299                 if (OP(oscan) != CURLYX) {
5300                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5301                            && NEXT_OFF(next))
5302                         NEXT_OFF(oscan) += NEXT_OFF(next);
5303                 }
5304                 continue;
5305
5306             default:
5307 #ifdef DEBUGGING
5308                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5309                                                                     OP(scan));
5310 #endif
5311             case REF:
5312             case CLUMP:
5313                 if (flags & SCF_DO_SUBSTR) {
5314                     /* Cannot expect anything... */
5315                     scan_commit(pRExC_state, data, minlenp, is_inf);
5316                     data->longest = &(data->longest_float);
5317                 }
5318                 is_inf = is_inf_internal = 1;
5319                 if (flags & SCF_DO_STCLASS_OR) {
5320                     if (OP(scan) == CLUMP) {
5321                         /* Actually is any start char, but very few code points
5322                          * aren't start characters */
5323                         ssc_match_all_cp(data->start_class);
5324                     }
5325                     else {
5326                         ssc_anything(data->start_class);
5327                     }
5328                 }
5329                 flags &= ~SCF_DO_STCLASS;
5330                 break;
5331             }
5332         }
5333         else if (OP(scan) == LNBREAK) {
5334             if (flags & SCF_DO_STCLASS) {
5335                 if (flags & SCF_DO_STCLASS_AND) {
5336                     ssc_intersection(data->start_class,
5337                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5338                     ssc_clear_locale(data->start_class);
5339                     ANYOF_FLAGS(data->start_class)
5340                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5341                 }
5342                 else if (flags & SCF_DO_STCLASS_OR) {
5343                     ssc_union(data->start_class,
5344                               PL_XPosix_ptrs[_CC_VERTSPACE],
5345                               FALSE);
5346                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5347
5348                     /* See commit msg for
5349                      * 749e076fceedeb708a624933726e7989f2302f6a */
5350                     ANYOF_FLAGS(data->start_class)
5351                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5352                 }
5353                 flags &= ~SCF_DO_STCLASS;
5354             }
5355             min++;
5356             if (delta != SSize_t_MAX)
5357                 delta++;    /* Because of the 2 char string cr-lf */
5358             if (flags & SCF_DO_SUBSTR) {
5359                 /* Cannot expect anything... */
5360                 scan_commit(pRExC_state, data, minlenp, is_inf);
5361                 data->pos_min += 1;
5362                 data->pos_delta += 1;
5363                 data->longest = &(data->longest_float);
5364             }
5365         }
5366         else if (REGNODE_SIMPLE(OP(scan))) {
5367
5368             if (flags & SCF_DO_SUBSTR) {
5369                 scan_commit(pRExC_state, data, minlenp, is_inf);
5370                 data->pos_min++;
5371             }
5372             min++;
5373             if (flags & SCF_DO_STCLASS) {
5374                 bool invert = 0;
5375                 SV* my_invlist = NULL;
5376                 U8 namedclass;
5377
5378                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5379                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5380
5381                 /* Some of the logic below assumes that switching
5382                    locale on will only add false positives. */
5383                 switch (OP(scan)) {
5384
5385                 default:
5386 #ifdef DEBUGGING
5387                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5388                                                                      OP(scan));
5389 #endif
5390                 case SANY:
5391                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5392                         ssc_match_all_cp(data->start_class);
5393                     break;
5394
5395                 case REG_ANY:
5396                     {
5397                         SV* REG_ANY_invlist = _new_invlist(2);
5398                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5399                                                             '\n');
5400                         if (flags & SCF_DO_STCLASS_OR) {
5401                             ssc_union(data->start_class,
5402                                       REG_ANY_invlist,
5403                                       TRUE /* TRUE => invert, hence all but \n
5404                                             */
5405                                       );
5406                         }
5407                         else if (flags & SCF_DO_STCLASS_AND) {
5408                             ssc_intersection(data->start_class,
5409                                              REG_ANY_invlist,
5410                                              TRUE  /* TRUE => invert */
5411                                              );
5412                             ssc_clear_locale(data->start_class);
5413                         }
5414                         SvREFCNT_dec_NN(REG_ANY_invlist);
5415                     }
5416                     break;
5417
5418                 case ANYOFD:
5419                 case ANYOFL:
5420                 case ANYOF:
5421                     if (flags & SCF_DO_STCLASS_AND)
5422                         ssc_and(pRExC_state, data->start_class,
5423                                 (regnode_charclass *) scan);
5424                     else
5425                         ssc_or(pRExC_state, data->start_class,
5426                                                           (regnode_charclass *) scan);
5427                     break;
5428
5429                 case NPOSIXL:
5430                     invert = 1;
5431                     /* FALLTHROUGH */
5432
5433                 case POSIXL:
5434                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5435                     if (flags & SCF_DO_STCLASS_AND) {
5436                         bool was_there = cBOOL(
5437                                           ANYOF_POSIXL_TEST(data->start_class,
5438                                                                  namedclass));
5439                         ANYOF_POSIXL_ZERO(data->start_class);
5440                         if (was_there) {    /* Do an AND */
5441                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5442                         }
5443                         /* No individual code points can now match */
5444                         data->start_class->invlist
5445                                                 = sv_2mortal(_new_invlist(0));
5446                     }
5447                     else {
5448                         int complement = namedclass + ((invert) ? -1 : 1);
5449
5450                         assert(flags & SCF_DO_STCLASS_OR);
5451
5452                         /* If the complement of this class was already there,
5453                          * the result is that they match all code points,
5454                          * (\d + \D == everything).  Remove the classes from
5455                          * future consideration.  Locale is not relevant in
5456                          * this case */
5457                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5458                             ssc_match_all_cp(data->start_class);
5459                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5460                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5461                         }
5462                         else {  /* The usual case; just add this class to the
5463                                    existing set */
5464                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5465                         }
5466                     }
5467                     break;
5468
5469                 case NPOSIXA:   /* For these, we always know the exact set of
5470                                    what's matched */
5471                     invert = 1;
5472                     /* FALLTHROUGH */
5473                 case POSIXA:
5474                     if (FLAGS(scan) == _CC_ASCII) {
5475                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5476                     }
5477                     else {
5478                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5479                                               PL_XPosix_ptrs[_CC_ASCII],
5480                                               &my_invlist);
5481                     }
5482                     goto join_posix;
5483
5484                 case NPOSIXD:
5485                 case NPOSIXU:
5486                     invert = 1;
5487                     /* FALLTHROUGH */
5488                 case POSIXD:
5489                 case POSIXU:
5490                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5491
5492                     /* NPOSIXD matches all upper Latin1 code points unless the
5493                      * target string being matched is UTF-8, which is
5494                      * unknowable until match time.  Since we are going to
5495                      * invert, we want to get rid of all of them so that the
5496                      * inversion will match all */
5497                     if (OP(scan) == NPOSIXD) {
5498                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5499                                           &my_invlist);
5500                     }
5501
5502                   join_posix:
5503
5504                     if (flags & SCF_DO_STCLASS_AND) {
5505                         ssc_intersection(data->start_class, my_invlist, invert);
5506                         ssc_clear_locale(data->start_class);
5507                     }
5508                     else {
5509                         assert(flags & SCF_DO_STCLASS_OR);
5510                         ssc_union(data->start_class, my_invlist, invert);
5511                     }
5512                     SvREFCNT_dec(my_invlist);
5513                 }
5514                 if (flags & SCF_DO_STCLASS_OR)
5515                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5516                 flags &= ~SCF_DO_STCLASS;
5517             }
5518         }
5519         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5520             data->flags |= (OP(scan) == MEOL
5521                             ? SF_BEFORE_MEOL
5522                             : SF_BEFORE_SEOL);
5523             scan_commit(pRExC_state, data, minlenp, is_inf);
5524
5525         }
5526         else if (  PL_regkind[OP(scan)] == BRANCHJ
5527                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5528                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5529                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5530         {
5531             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5532                 || OP(scan) == UNLESSM )
5533             {
5534                 /* Negative Lookahead/lookbehind
5535                    In this case we can't do fixed string optimisation.
5536                 */
5537
5538                 SSize_t deltanext, minnext, fake = 0;
5539                 regnode *nscan;
5540                 regnode_ssc intrnl;
5541                 int f = 0;
5542
5543                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5544                 if (data) {
5545                     data_fake.whilem_c = data->whilem_c;
5546                     data_fake.last_closep = data->last_closep;
5547                 }
5548                 else
5549                     data_fake.last_closep = &fake;
5550                 data_fake.pos_delta = delta;
5551                 if ( flags & SCF_DO_STCLASS && !scan->flags
5552                      && OP(scan) == IFMATCH ) { /* Lookahead */
5553                     ssc_init(pRExC_state, &intrnl);
5554                     data_fake.start_class = &intrnl;
5555                     f |= SCF_DO_STCLASS_AND;
5556                 }
5557                 if (flags & SCF_WHILEM_VISITED_POS)
5558                     f |= SCF_WHILEM_VISITED_POS;
5559                 next = regnext(scan);
5560                 nscan = NEXTOPER(NEXTOPER(scan));
5561                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5562                                       last, &data_fake, stopparen,
5563                                       recursed_depth, NULL, f, depth+1);
5564                 if (scan->flags) {
5565                     if (deltanext) {
5566                         FAIL("Variable length lookbehind not implemented");
5567                     }
5568                     else if (minnext > (I32)U8_MAX) {
5569                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5570                               (UV)U8_MAX);
5571                     }
5572                     scan->flags = (U8)minnext;
5573                 }
5574                 if (data) {
5575                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5576                         pars++;
5577                     if (data_fake.flags & SF_HAS_EVAL)
5578                         data->flags |= SF_HAS_EVAL;
5579                     data->whilem_c = data_fake.whilem_c;
5580                 }
5581                 if (f & SCF_DO_STCLASS_AND) {
5582                     if (flags & SCF_DO_STCLASS_OR) {
5583                         /* OR before, AND after: ideally we would recurse with
5584                          * data_fake to get the AND applied by study of the
5585                          * remainder of the pattern, and then derecurse;
5586                          * *** HACK *** for now just treat as "no information".
5587                          * See [perl #56690].
5588                          */
5589                         ssc_init(pRExC_state, data->start_class);
5590                     }  else {
5591                         /* AND before and after: combine and continue.  These
5592                          * assertions are zero-length, so can match an EMPTY
5593                          * string */
5594                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5595                         ANYOF_FLAGS(data->start_class)
5596                                                    |= SSC_MATCHES_EMPTY_STRING;
5597                     }
5598                 }
5599             }
5600 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5601             else {
5602                 /* Positive Lookahead/lookbehind
5603                    In this case we can do fixed string optimisation,
5604                    but we must be careful about it. Note in the case of
5605                    lookbehind the positions will be offset by the minimum
5606                    length of the pattern, something we won't know about
5607                    until after the recurse.
5608                 */
5609                 SSize_t deltanext, fake = 0;
5610                 regnode *nscan;
5611                 regnode_ssc intrnl;
5612                 int f = 0;
5613                 /* We use SAVEFREEPV so that when the full compile
5614                     is finished perl will clean up the allocated
5615                     minlens when it's all done. This way we don't
5616                     have to worry about freeing them when we know
5617                     they wont be used, which would be a pain.
5618                  */
5619                 SSize_t *minnextp;
5620                 Newx( minnextp, 1, SSize_t );
5621                 SAVEFREEPV(minnextp);
5622
5623                 if (data) {
5624                     StructCopy(data, &data_fake, scan_data_t);
5625                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5626                         f |= SCF_DO_SUBSTR;
5627                         if (scan->flags)
5628                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5629                         data_fake.last_found=newSVsv(data->last_found);
5630                     }
5631                 }
5632                 else
5633                     data_fake.last_closep = &fake;
5634                 data_fake.flags = 0;
5635                 data_fake.pos_delta = delta;
5636                 if (is_inf)
5637                     data_fake.flags |= SF_IS_INF;
5638                 if ( flags & SCF_DO_STCLASS && !scan->flags
5639                      && OP(scan) == IFMATCH ) { /* Lookahead */
5640                     ssc_init(pRExC_state, &intrnl);
5641                     data_fake.start_class = &intrnl;
5642                     f |= SCF_DO_STCLASS_AND;
5643                 }
5644                 if (flags & SCF_WHILEM_VISITED_POS)
5645                     f |= SCF_WHILEM_VISITED_POS;
5646                 next = regnext(scan);
5647                 nscan = NEXTOPER(NEXTOPER(scan));
5648
5649                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5650                                         &deltanext, last, &data_fake,
5651                                         stopparen, recursed_depth, NULL,
5652                                         f,depth+1);
5653                 if (scan->flags) {
5654                     if (deltanext) {
5655                         FAIL("Variable length lookbehind not implemented");
5656                     }
5657                     else if (*minnextp > (I32)U8_MAX) {
5658                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5659                               (UV)U8_MAX);
5660                     }
5661                     scan->flags = (U8)*minnextp;
5662                 }
5663
5664                 *minnextp += min;
5665
5666                 if (f & SCF_DO_STCLASS_AND) {
5667                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5668                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5669                 }
5670                 if (data) {
5671                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5672                         pars++;
5673                     if (data_fake.flags & SF_HAS_EVAL)
5674                         data->flags |= SF_HAS_EVAL;
5675                     data->whilem_c = data_fake.whilem_c;
5676                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5677                         if (RExC_rx->minlen<*minnextp)
5678                             RExC_rx->minlen=*minnextp;
5679                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5680                         SvREFCNT_dec_NN(data_fake.last_found);
5681
5682                         if ( data_fake.minlen_fixed != minlenp )
5683                         {
5684                             data->offset_fixed= data_fake.offset_fixed;
5685                             data->minlen_fixed= data_fake.minlen_fixed;
5686                             data->lookbehind_fixed+= scan->flags;
5687                         }
5688                         if ( data_fake.minlen_float != minlenp )
5689                         {
5690                             data->minlen_float= data_fake.minlen_float;
5691                             data->offset_float_min=data_fake.offset_float_min;
5692                             data->offset_float_max=data_fake.offset_float_max;
5693                             data->lookbehind_float+= scan->flags;
5694                         }
5695                     }
5696                 }
5697             }
5698 #endif
5699         }
5700         else if (OP(scan) == OPEN) {
5701             if (stopparen != (I32)ARG(scan))
5702                 pars++;
5703         }
5704         else if (OP(scan) == CLOSE) {
5705             if (stopparen == (I32)ARG(scan)) {
5706                 break;
5707             }
5708             if ((I32)ARG(scan) == is_par) {
5709                 next = regnext(scan);
5710
5711                 if ( next && (OP(next) != WHILEM) && next < last)
5712                     is_par = 0;         /* Disable optimization */
5713             }
5714             if (data)
5715                 *(data->last_closep) = ARG(scan);
5716         }
5717         else if (OP(scan) == EVAL) {
5718                 if (data)
5719                     data->flags |= SF_HAS_EVAL;
5720         }
5721         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5722             if (flags & SCF_DO_SUBSTR) {
5723                 scan_commit(pRExC_state, data, minlenp, is_inf);
5724                 flags &= ~SCF_DO_SUBSTR;
5725             }
5726             if (data && OP(scan)==ACCEPT) {
5727                 data->flags |= SCF_SEEN_ACCEPT;
5728                 if (stopmin > min)
5729                     stopmin = min;
5730             }
5731         }
5732         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5733         {
5734                 if (flags & SCF_DO_SUBSTR) {
5735                     scan_commit(pRExC_state, data, minlenp, is_inf);
5736                     data->longest = &(data->longest_float);
5737                 }
5738                 is_inf = is_inf_internal = 1;
5739                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5740                     ssc_anything(data->start_class);
5741                 flags &= ~SCF_DO_STCLASS;
5742         }
5743         else if (OP(scan) == GPOS) {
5744             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5745                 !(delta || is_inf || (data && data->pos_delta)))
5746             {
5747                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5748                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5749                 if (RExC_rx->gofs < (STRLEN)min)
5750                     RExC_rx->gofs = min;
5751             } else {
5752                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5753                 RExC_rx->gofs = 0;
5754             }
5755         }
5756 #ifdef TRIE_STUDY_OPT
5757 #ifdef FULL_TRIE_STUDY
5758         else if (PL_regkind[OP(scan)] == TRIE) {
5759             /* NOTE - There is similar code to this block above for handling
5760                BRANCH nodes on the initial study.  If you change stuff here
5761                check there too. */
5762             regnode *trie_node= scan;
5763             regnode *tail= regnext(scan);
5764             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5765             SSize_t max1 = 0, min1 = SSize_t_MAX;
5766             regnode_ssc accum;
5767
5768             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5769                 /* Cannot merge strings after this. */
5770                 scan_commit(pRExC_state, data, minlenp, is_inf);
5771             }
5772             if (flags & SCF_DO_STCLASS)
5773                 ssc_init_zero(pRExC_state, &accum);
5774
5775             if (!trie->jump) {
5776                 min1= trie->minlen;
5777                 max1= trie->maxlen;
5778             } else {
5779                 const regnode *nextbranch= NULL;
5780                 U32 word;
5781
5782                 for ( word=1 ; word <= trie->wordcount ; word++)
5783                 {
5784                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5785                     regnode_ssc this_class;
5786
5787                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5788                     if (data) {
5789                         data_fake.whilem_c = data->whilem_c;
5790                         data_fake.last_closep = data->last_closep;
5791                     }
5792                     else
5793                         data_fake.last_closep = &fake;
5794                     data_fake.pos_delta = delta;
5795                     if (flags & SCF_DO_STCLASS) {
5796                         ssc_init(pRExC_state, &this_class);
5797                         data_fake.start_class = &this_class;
5798                         f = SCF_DO_STCLASS_AND;
5799                     }
5800                     if (flags & SCF_WHILEM_VISITED_POS)
5801                         f |= SCF_WHILEM_VISITED_POS;
5802
5803                     if (trie->jump[word]) {
5804                         if (!nextbranch)
5805                             nextbranch = trie_node + trie->jump[0];
5806                         scan= trie_node + trie->jump[word];
5807                         /* We go from the jump point to the branch that follows
5808                            it. Note this means we need the vestigal unused
5809                            branches even though they arent otherwise used. */
5810                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5811                             &deltanext, (regnode *)nextbranch, &data_fake,
5812                             stopparen, recursed_depth, NULL, f,depth+1);
5813                     }
5814                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5815                         nextbranch= regnext((regnode*)nextbranch);
5816
5817                     if (min1 > (SSize_t)(minnext + trie->minlen))
5818                         min1 = minnext + trie->minlen;
5819                     if (deltanext == SSize_t_MAX) {
5820                         is_inf = is_inf_internal = 1;
5821                         max1 = SSize_t_MAX;
5822                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5823                         max1 = minnext + deltanext + trie->maxlen;
5824
5825                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5826                         pars++;
5827                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5828                         if ( stopmin > min + min1)
5829                             stopmin = min + min1;
5830                         flags &= ~SCF_DO_SUBSTR;
5831                         if (data)
5832                             data->flags |= SCF_SEEN_ACCEPT;
5833                     }
5834                     if (data) {
5835                         if (data_fake.flags & SF_HAS_EVAL)
5836                             data->flags |= SF_HAS_EVAL;
5837                         data->whilem_c = data_fake.whilem_c;
5838                     }
5839                     if (flags & SCF_DO_STCLASS)
5840                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5841                 }
5842             }
5843             if (flags & SCF_DO_SUBSTR) {
5844                 data->pos_min += min1;
5845                 data->pos_delta += max1 - min1;
5846                 if (max1 != min1 || is_inf)
5847                     data->longest = &(data->longest_float);
5848             }
5849             min += min1;
5850             if (delta != SSize_t_MAX)
5851                 delta += max1 - min1;
5852             if (flags & SCF_DO_STCLASS_OR) {
5853                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5854                 if (min1) {
5855                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5856                     flags &= ~SCF_DO_STCLASS;
5857                 }
5858             }
5859             else if (flags & SCF_DO_STCLASS_AND) {
5860                 if (min1) {
5861                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5862                     flags &= ~SCF_DO_STCLASS;
5863                 }
5864                 else {
5865                     /* Switch to OR mode: cache the old value of
5866                      * data->start_class */
5867                     INIT_AND_WITHP;
5868                     StructCopy(data->start_class, and_withp, regnode_ssc);
5869                     flags &= ~SCF_DO_STCLASS_AND;
5870                     StructCopy(&accum, data->start_class, regnode_ssc);
5871                     flags |= SCF_DO_STCLASS_OR;
5872                 }
5873             }
5874             scan= tail;
5875             continue;
5876         }
5877 #else
5878         else if (PL_regkind[OP(scan)] == TRIE) {
5879             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5880             U8*bang=NULL;
5881
5882             min += trie->minlen;
5883             delta += (trie->maxlen - trie->minlen);
5884             flags &= ~SCF_DO_STCLASS; /* xxx */
5885             if (flags & SCF_DO_SUBSTR) {
5886                 /* Cannot expect anything... */
5887                 scan_commit(pRExC_state, data, minlenp, is_inf);
5888                 data->pos_min += trie->minlen;
5889                 data->pos_delta += (trie->maxlen - trie->minlen);
5890                 if (trie->maxlen != trie->minlen)
5891                     data->longest = &(data->longest_float);
5892             }
5893             if (trie->jump) /* no more substrings -- for now /grr*/
5894                flags &= ~SCF_DO_SUBSTR;
5895         }
5896 #endif /* old or new */
5897 #endif /* TRIE_STUDY_OPT */
5898
5899         /* Else: zero-length, ignore. */
5900         scan = regnext(scan);
5901     }
5902     /* If we are exiting a recursion we can unset its recursed bit
5903      * and allow ourselves to enter it again - no danger of an
5904      * infinite loop there.
5905     if (stopparen > -1 && recursed) {
5906         DEBUG_STUDYDATA("unset:", data,depth);
5907         PAREN_UNSET( recursed, stopparen);
5908     }
5909     */
5910     if (frame) {
5911         depth = depth - 1;
5912
5913         DEBUG_STUDYDATA("frame-end:",data,depth);
5914         DEBUG_PEEP("fend", scan, depth);
5915
5916         /* restore previous context */
5917         last = frame->last_regnode;
5918         scan = frame->next_regnode;
5919         stopparen = frame->stopparen;
5920         recursed_depth = frame->prev_recursed_depth;
5921
5922         RExC_frame_last = frame->prev_frame;
5923         frame = frame->this_prev_frame;
5924         goto fake_study_recurse;
5925     }
5926
5927   finish:
5928     assert(!frame);
5929     DEBUG_STUDYDATA("pre-fin:",data,depth);
5930
5931     *scanp = scan;
5932     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5933
5934     if (flags & SCF_DO_SUBSTR && is_inf)
5935         data->pos_delta = SSize_t_MAX - data->pos_min;
5936     if (is_par > (I32)U8_MAX)
5937         is_par = 0;
5938     if (is_par && pars==1 && data) {
5939         data->flags |= SF_IN_PAR;
5940         data->flags &= ~SF_HAS_PAR;
5941     }
5942     else if (pars && data) {
5943         data->flags |= SF_HAS_PAR;
5944         data->flags &= ~SF_IN_PAR;
5945     }
5946     if (flags & SCF_DO_STCLASS_OR)
5947         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5948     if (flags & SCF_TRIE_RESTUDY)
5949         data->flags |=  SCF_TRIE_RESTUDY;
5950
5951     DEBUG_STUDYDATA("post-fin:",data,depth);
5952
5953     {
5954         SSize_t final_minlen= min < stopmin ? min : stopmin;
5955
5956         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
5957             if (final_minlen > SSize_t_MAX - delta)
5958                 RExC_maxlen = SSize_t_MAX;
5959             else if (RExC_maxlen < final_minlen + delta)
5960                 RExC_maxlen = final_minlen + delta;
5961         }
5962         return final_minlen;
5963     }
5964     NOT_REACHED; /* NOTREACHED */
5965 }
5966
5967 STATIC U32
5968 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5969 {
5970     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5971
5972     PERL_ARGS_ASSERT_ADD_DATA;
5973
5974     Renewc(RExC_rxi->data,
5975            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
5976            char, struct reg_data);
5977     if(count)
5978         Renew(RExC_rxi->data->what, count + n, U8);
5979     else
5980         Newx(RExC_rxi->data->what, n, U8);
5981     RExC_rxi->data->count = count + n;
5982     Copy(s, RExC_rxi->data->what + count, n, U8);
5983     return count;
5984 }
5985
5986 /*XXX: todo make this not included in a non debugging perl, but appears to be
5987  * used anyway there, in 'use re' */
5988 #ifndef PERL_IN_XSUB_RE
5989 void
5990 Perl_reginitcolors(pTHX)
5991 {
5992     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
5993     if (s) {
5994         char *t = savepv(s);
5995         int i = 0;
5996         PL_colors[0] = t;
5997         while (++i < 6) {
5998             t = strchr(t, '\t');
5999             if (t) {
6000                 *t = '\0';
6001                 PL_colors[i] = ++t;
6002             }
6003             else
6004                 PL_colors[i] = t = (char *)"";
6005         }
6006     } else {
6007         int i = 0;
6008         while (i < 6)
6009             PL_colors[i++] = (char *)"";
6010     }
6011     PL_colorset = 1;
6012 }
6013 #endif
6014
6015
6016 #ifdef TRIE_STUDY_OPT
6017 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6018     STMT_START {                                            \
6019         if (                                                \
6020               (data.flags & SCF_TRIE_RESTUDY)               \
6021               && ! restudied++                              \
6022         ) {                                                 \
6023             dOsomething;                                    \
6024             goto reStudy;                                   \
6025         }                                                   \
6026     } STMT_END
6027 #else
6028 #define CHECK_RESTUDY_GOTO_butfirst
6029 #endif
6030
6031 /*
6032  * pregcomp - compile a regular expression into internal code
6033  *
6034  * Decides which engine's compiler to call based on the hint currently in
6035  * scope
6036  */
6037
6038 #ifndef PERL_IN_XSUB_RE
6039
6040 /* return the currently in-scope regex engine (or the default if none)  */
6041
6042 regexp_engine const *
6043 Perl_current_re_engine(pTHX)
6044 {
6045     if (IN_PERL_COMPILETIME) {
6046         HV * const table = GvHV(PL_hintgv);
6047         SV **ptr;
6048
6049         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6050             return &PL_core_reg_engine;
6051         ptr = hv_fetchs(table, "regcomp", FALSE);
6052         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6053             return &PL_core_reg_engine;
6054         return INT2PTR(regexp_engine*,SvIV(*ptr));
6055     }
6056     else {
6057         SV *ptr;
6058         if (!PL_curcop->cop_hints_hash)
6059             return &PL_core_reg_engine;
6060         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6061         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6062             return &PL_core_reg_engine;
6063         return INT2PTR(regexp_engine*,SvIV(ptr));
6064     }
6065 }
6066
6067
6068 REGEXP *
6069 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6070 {
6071     regexp_engine const *eng = current_re_engine();
6072     GET_RE_DEBUG_FLAGS_DECL;
6073
6074     PERL_ARGS_ASSERT_PREGCOMP;
6075
6076     /* Dispatch a request to compile a regexp to correct regexp engine. */
6077     DEBUG_COMPILE_r({
6078         Perl_re_printf( aTHX_  "Using engine %"UVxf"\n",
6079                         PTR2UV(eng));
6080     });
6081     return CALLREGCOMP_ENG(eng, pattern, flags);
6082 }
6083 #endif
6084
6085 /* public(ish) entry point for the perl core's own regex compiling code.
6086  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6087  * pattern rather than a list of OPs, and uses the internal engine rather
6088  * than the current one */
6089
6090 REGEXP *
6091 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6092 {
6093     SV *pat = pattern; /* defeat constness! */
6094     PERL_ARGS_ASSERT_RE_COMPILE;
6095     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6096 #ifdef PERL_IN_XSUB_RE
6097                                 &my_reg_engine,
6098 #else
6099                                 &PL_core_reg_engine,
6100 #endif
6101                                 NULL, NULL, rx_flags, 0);
6102 }
6103
6104
6105 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6106  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6107  * point to the realloced string and length.
6108  *
6109  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6110  * stuff added */
6111
6112 static void
6113 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6114                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6115 {
6116     U8 *const src = (U8*)*pat_p;
6117     U8 *dst, *d;
6118     int n=0;
6119     STRLEN s = 0;
6120     bool do_end = 0;
6121     GET_RE_DEBUG_FLAGS_DECL;
6122
6123     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6124         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6125
6126     Newx(dst, *plen_p * 2 + 1, U8);
6127     d = dst;
6128
6129     while (s < *plen_p) {
6130         append_utf8_from_native_byte(src[s], &d);
6131         if (n < num_code_blocks) {
6132             if (!do_end && pRExC_state->code_blocks[n].start == s) {
6133                 pRExC_state->code_blocks[n].start = d - dst - 1;
6134                 assert(*(d - 1) == '(');
6135                 do_end = 1;
6136             }
6137             else if (do_end && pRExC_state->code_blocks[n].end == s) {
6138                 pRExC_state->code_blocks[n].end = d - dst - 1;
6139                 assert(*(d - 1) == ')');
6140                 do_end = 0;
6141                 n++;
6142             }
6143         }
6144         s++;
6145     }
6146     *d = '\0';
6147     *plen_p = d - dst;
6148     *pat_p = (char*) dst;
6149     SAVEFREEPV(*pat_p);
6150     RExC_orig_utf8 = RExC_utf8 = 1;
6151 }
6152
6153
6154
6155 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6156  * while recording any code block indices, and handling overloading,
6157  * nested qr// objects etc.  If pat is null, it will allocate a new
6158  * string, or just return the first arg, if there's only one.
6159  *
6160  * Returns the malloced/updated pat.
6161  * patternp and pat_count is the array of SVs to be concatted;
6162  * oplist is the optional list of ops that generated the SVs;
6163  * recompile_p is a pointer to a boolean that will be set if
6164  *   the regex will need to be recompiled.
6165  * delim, if non-null is an SV that will be inserted between each element
6166  */
6167
6168 static SV*
6169 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6170                 SV *pat, SV ** const patternp, int pat_count,
6171                 OP *oplist, bool *recompile_p, SV *delim)
6172 {
6173     SV **svp;
6174     int n = 0;
6175     bool use_delim = FALSE;
6176     bool alloced = FALSE;
6177
6178     /* if we know we have at least two args, create an empty string,
6179      * then concatenate args to that. For no args, return an empty string */
6180     if (!pat && pat_count != 1) {
6181         pat = newSVpvs("");
6182         SAVEFREESV(pat);
6183         alloced = TRUE;
6184     }
6185
6186     for (svp = patternp; svp < patternp + pat_count; svp++) {
6187         SV *sv;
6188         SV *rx  = NULL;
6189         STRLEN orig_patlen = 0;
6190         bool code = 0;
6191         SV *msv = use_delim ? delim : *svp;
6192         if (!msv) msv = &PL_sv_undef;
6193
6194         /* if we've got a delimiter, we go round the loop twice for each
6195          * svp slot (except the last), using the delimiter the second
6196          * time round */
6197         if (use_delim) {
6198             svp--;
6199             use_delim = FALSE;
6200         }
6201         else if (delim)
6202             use_delim = TRUE;
6203
6204         if (SvTYPE(msv) == SVt_PVAV) {
6205             /* we've encountered an interpolated array within
6206              * the pattern, e.g. /...@a..../. Expand the list of elements,
6207              * then recursively append elements.
6208              * The code in this block is based on S_pushav() */
6209
6210             AV *const av = (AV*)msv;
6211             const SSize_t maxarg = AvFILL(av) + 1;
6212             SV **array;
6213
6214             if (oplist) {
6215                 assert(oplist->op_type == OP_PADAV
6216                     || oplist->op_type == OP_RV2AV);
6217                 oplist = OpSIBLING(oplist);
6218             }
6219
6220             if (SvRMAGICAL(av)) {
6221                 SSize_t i;
6222
6223                 Newx(array, maxarg, SV*);
6224                 SAVEFREEPV(array);
6225                 for (i=0; i < maxarg; i++) {
6226                     SV ** const svp = av_fetch(av, i, FALSE);
6227                     array[i] = svp ? *svp : &PL_sv_undef;
6228                 }
6229             }
6230             else
6231                 array = AvARRAY(av);
6232
6233             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6234                                 array, maxarg, NULL, recompile_p,
6235                                 /* $" */
6236                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6237
6238             continue;
6239         }
6240
6241
6242         /* we make the assumption here that each op in the list of
6243          * op_siblings maps to one SV pushed onto the stack,
6244          * except for code blocks, with have both an OP_NULL and
6245          * and OP_CONST.
6246          * This allows us to match up the list of SVs against the
6247          * list of OPs to find the next code block.
6248          *
6249          * Note that       PUSHMARK PADSV PADSV ..
6250          * is optimised to
6251          *                 PADRANGE PADSV  PADSV  ..
6252          * so the alignment still works. */
6253
6254         if (oplist) {
6255             if (oplist->op_type == OP_NULL
6256                 && (oplist->op_flags & OPf_SPECIAL))
6257             {
6258                 assert(n < pRExC_state->num_code_blocks);
6259                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
6260                 pRExC_state->code_blocks[n].block = oplist;
6261                 pRExC_state->code_blocks[n].src_regex = NULL;
6262                 n++;
6263                 code = 1;
6264                 oplist = OpSIBLING(oplist); /* skip CONST */
6265                 assert(oplist);
6266             }
6267             oplist = OpSIBLING(oplist);;
6268         }
6269
6270         /* apply magic and QR overloading to arg */
6271
6272         SvGETMAGIC(msv);
6273         if (SvROK(msv) && SvAMAGIC(msv)) {
6274             SV *sv = AMG_CALLunary(msv, regexp_amg);
6275             if (sv) {
6276                 if (SvROK(sv))
6277                     sv = SvRV(sv);
6278                 if (SvTYPE(sv) != SVt_REGEXP)
6279                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6280                 msv = sv;
6281             }
6282         }
6283
6284         /* try concatenation overload ... */
6285         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6286                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6287         {
6288             sv_setsv(pat, sv);
6289             /* overloading involved: all bets are off over literal
6290              * code. Pretend we haven't seen it */
6291             pRExC_state->num_code_blocks -= n;
6292             n = 0;
6293         }
6294         else  {
6295             /* ... or failing that, try "" overload */
6296             while (SvAMAGIC(msv)
6297                     && (sv = AMG_CALLunary(msv, string_amg))
6298                     && sv != msv
6299                     &&  !(   SvROK(msv)
6300                           && SvROK(sv)
6301                           && SvRV(msv) == SvRV(sv))
6302             ) {
6303                 msv = sv;
6304                 SvGETMAGIC(msv);
6305             }
6306             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6307                 msv = SvRV(msv);
6308
6309             if (pat) {
6310                 /* this is a partially unrolled
6311                  *     sv_catsv_nomg(pat, msv);
6312                  * that allows us to adjust code block indices if
6313                  * needed */
6314                 STRLEN dlen;
6315                 char *dst = SvPV_force_nomg(pat, dlen);
6316                 orig_patlen = dlen;
6317                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6318                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6319                     sv_setpvn(pat, dst, dlen);
6320                     SvUTF8_on(pat);
6321                 }
6322                 sv_catsv_nomg(pat, msv);
6323                 rx = msv;
6324             }
6325             else
6326                 pat = msv;
6327
6328             if (code)
6329                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
6330         }
6331
6332         /* extract any code blocks within any embedded qr//'s */
6333         if (rx && SvTYPE(rx) == SVt_REGEXP
6334             && RX_ENGINE((REGEXP*)rx)->op_comp)
6335         {
6336
6337             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6338             if (ri->num_code_blocks) {
6339                 int i;
6340                 /* the presence of an embedded qr// with code means
6341                  * we should always recompile: the text of the
6342                  * qr// may not have changed, but it may be a
6343                  * different closure than last time */
6344                 *recompile_p = 1;
6345                 Renew(pRExC_state->code_blocks,
6346                     pRExC_state->num_code_blocks + ri->num_code_blocks,
6347                     struct reg_code_block);
6348                 pRExC_state->num_code_blocks += ri->num_code_blocks;
6349
6350                 for (i=0; i < ri->num_code_blocks; i++) {
6351                     struct reg_code_block *src, *dst;
6352                     STRLEN offset =  orig_patlen
6353                         + ReANY((REGEXP *)rx)->pre_prefix;
6354                     assert(n < pRExC_state->num_code_blocks);
6355                     src = &ri->code_blocks[i];
6356                     dst = &pRExC_state->code_blocks[n];
6357                     dst->start      = src->start + offset;
6358                     dst->end        = src->end   + offset;
6359                     dst->block      = src->block;
6360                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6361                                             src->src_regex
6362                                                 ? src->src_regex
6363                                                 : (REGEXP*)rx);
6364                     n++;
6365                 }
6366             }
6367         }
6368     }
6369     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6370     if (alloced)
6371         SvSETMAGIC(pat);
6372
6373     return pat;
6374 }
6375
6376
6377
6378 /* see if there are any run-time code blocks in the pattern.
6379  * False positives are allowed */
6380
6381 static bool
6382 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6383                     char *pat, STRLEN plen)
6384 {
6385     int n = 0;
6386     STRLEN s;
6387     
6388     PERL_UNUSED_CONTEXT;
6389
6390     for (s = 0; s < plen; s++) {
6391         if (n < pRExC_state->num_code_blocks
6392             && s == pRExC_state->code_blocks[n].start)
6393         {
6394             s = pRExC_state->code_blocks[n].end;
6395             n++;
6396             continue;
6397         }
6398         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6399          * positives here */
6400         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6401             (pat[s+2] == '{'
6402                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6403         )
6404             return 1;
6405     }
6406     return 0;
6407 }
6408
6409 /* Handle run-time code blocks. We will already have compiled any direct
6410  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6411  * copy of it, but with any literal code blocks blanked out and
6412  * appropriate chars escaped; then feed it into
6413  *
6414  *    eval "qr'modified_pattern'"
6415  *
6416  * For example,
6417  *
6418  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6419  *
6420  * becomes
6421  *
6422  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6423  *
6424  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6425  * and merge them with any code blocks of the original regexp.
6426  *
6427  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6428  * instead, just save the qr and return FALSE; this tells our caller that
6429  * the original pattern needs upgrading to utf8.
6430  */
6431
6432 static bool
6433 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6434     char *pat, STRLEN plen)
6435 {
6436     SV *qr;
6437
6438     GET_RE_DEBUG_FLAGS_DECL;
6439
6440     if (pRExC_state->runtime_code_qr) {
6441         /* this is the second time we've been called; this should
6442          * only happen if the main pattern got upgraded to utf8
6443          * during compilation; re-use the qr we compiled first time
6444          * round (which should be utf8 too)
6445          */
6446         qr = pRExC_state->runtime_code_qr;
6447         pRExC_state->runtime_code_qr = NULL;
6448         assert(RExC_utf8 && SvUTF8(qr));
6449     }
6450     else {
6451         int n = 0;
6452         STRLEN s;
6453         char *p, *newpat;
6454         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
6455         SV *sv, *qr_ref;
6456         dSP;
6457
6458         /* determine how many extra chars we need for ' and \ escaping */
6459         for (s = 0; s < plen; s++) {
6460             if (pat[s] == '\'' || pat[s] == '\\')
6461                 newlen++;
6462         }
6463
6464         Newx(newpat, newlen, char);
6465         p = newpat;
6466         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6467
6468         for (s = 0; s < plen; s++) {
6469             if (n < pRExC_state->num_code_blocks
6470                 && s == pRExC_state->code_blocks[n].start)
6471             {
6472                 /* blank out literal code block */
6473                 assert(pat[s] == '(');
6474                 while (s <= pRExC_state->code_blocks[n].end) {
6475                     *p++ = '_';
6476                     s++;
6477                 }
6478                 s--;
6479                 n++;
6480                 continue;
6481             }
6482             if (pat[s] == '\'' || pat[s] == '\\')
6483                 *p++ = '\\';
6484             *p++ = pat[s];
6485         }
6486         *p++ = '\'';
6487         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
6488             *p++ = 'x';
6489         *p++ = '\0';
6490         DEBUG_COMPILE_r({
6491             Perl_re_printf( aTHX_
6492                 "%sre-parsing pattern for runtime code:%s %s\n",
6493                 PL_colors[4],PL_colors[5],newpat);
6494         });
6495
6496         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6497         Safefree(newpat);
6498
6499         ENTER;
6500         SAVETMPS;
6501         save_re_context();
6502         PUSHSTACKi(PERLSI_REQUIRE);
6503         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6504          * parsing qr''; normally only q'' does this. It also alters
6505          * hints handling */
6506         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6507         SvREFCNT_dec_NN(sv);
6508         SPAGAIN;
6509         qr_ref = POPs;
6510         PUTBACK;
6511         {
6512             SV * const errsv = ERRSV;
6513             if (SvTRUE_NN(errsv))
6514             {
6515                 Safefree(pRExC_state->code_blocks);
6516                 /* use croak_sv ? */
6517                 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
6518             }
6519         }
6520         assert(SvROK(qr_ref));
6521         qr = SvRV(qr_ref);
6522         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6523         /* the leaving below frees the tmp qr_ref.
6524          * Give qr a life of its own */
6525         SvREFCNT_inc(qr);
6526         POPSTACK;
6527         FREETMPS;
6528         LEAVE;
6529
6530     }
6531
6532     if (!RExC_utf8 && SvUTF8(qr)) {
6533         /* first time through; the pattern got upgraded; save the
6534          * qr for the next time through */
6535         assert(!pRExC_state->runtime_code_qr);
6536         pRExC_state->runtime_code_qr = qr;
6537         return 0;
6538     }
6539
6540
6541     /* extract any code blocks within the returned qr//  */
6542
6543
6544     /* merge the main (r1) and run-time (r2) code blocks into one */
6545     {
6546         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6547         struct reg_code_block *new_block, *dst;
6548         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6549         int i1 = 0, i2 = 0;
6550
6551         if (!r2->num_code_blocks) /* we guessed wrong */
6552         {
6553             SvREFCNT_dec_NN(qr);
6554             return 1;
6555         }
6556
6557         Newx(new_block,
6558             r1->num_code_blocks + r2->num_code_blocks,
6559             struct reg_code_block);
6560         dst = new_block;
6561
6562         while (    i1 < r1->num_code_blocks
6563                 || i2 < r2->num_code_blocks)
6564         {
6565             struct reg_code_block *src;
6566             bool is_qr = 0;
6567
6568             if (i1 == r1->num_code_blocks) {
6569                 src = &r2->code_blocks[i2++];
6570                 is_qr = 1;
6571             }
6572             else if (i2 == r2->num_code_blocks)
6573                 src = &r1->code_blocks[i1++];
6574             else if (  r1->code_blocks[i1].start
6575                      < r2->code_blocks[i2].start)
6576             {
6577                 src = &r1->code_blocks[i1++];
6578                 assert(src->end < r2->code_blocks[i2].start);
6579             }
6580             else {
6581                 assert(  r1->code_blocks[i1].start
6582                        > r2->code_blocks[i2].start);
6583                 src = &r2->code_blocks[i2++];
6584                 is_qr = 1;
6585                 assert(src->end < r1->code_blocks[i1].start);
6586             }
6587
6588             assert(pat[src->start] == '(');
6589             assert(pat[src->end]   == ')');
6590             dst->start      = src->start;
6591             dst->end        = src->end;
6592             dst->block      = src->block;
6593             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6594                                     : src->src_regex;
6595             dst++;
6596         }
6597         r1->num_code_blocks += r2->num_code_blocks;
6598         Safefree(r1->code_blocks);
6599         r1->code_blocks = new_block;
6600     }
6601
6602     SvREFCNT_dec_NN(qr);
6603     return 1;
6604 }
6605
6606
6607 STATIC bool
6608 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6609                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6610                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6611                       STRLEN longest_length, bool eol, bool meol)
6612 {
6613     /* This is the common code for setting up the floating and fixed length
6614      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6615      * as to whether succeeded or not */
6616
6617     I32 t;
6618     SSize_t ml;
6619
6620     if (! (longest_length
6621            || (eol /* Can't have SEOL and MULTI */
6622                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6623           )
6624             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6625         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6626     {
6627         return FALSE;
6628     }
6629
6630     /* copy the information about the longest from the reg_scan_data
6631         over to the program. */
6632     if (SvUTF8(sv_longest)) {
6633         *rx_utf8 = sv_longest;
6634         *rx_substr = NULL;
6635     } else {
6636         *rx_substr = sv_longest;
6637         *rx_utf8 = NULL;
6638     }
6639     /* end_shift is how many chars that must be matched that
6640         follow this item. We calculate it ahead of time as once the
6641         lookbehind offset is added in we lose the ability to correctly
6642         calculate it.*/
6643     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6644     *rx_end_shift = ml - offset
6645         - longest_length + (SvTAIL(sv_longest) != 0)
6646         + lookbehind;
6647
6648     t = (eol/* Can't have SEOL and MULTI */
6649          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6650     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6651
6652     return TRUE;
6653 }
6654
6655 /*
6656  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6657  * regular expression into internal code.
6658  * The pattern may be passed either as:
6659  *    a list of SVs (patternp plus pat_count)
6660  *    a list of OPs (expr)
6661  * If both are passed, the SV list is used, but the OP list indicates
6662  * which SVs are actually pre-compiled code blocks
6663  *
6664  * The SVs in the list have magic and qr overloading applied to them (and
6665  * the list may be modified in-place with replacement SVs in the latter
6666  * case).
6667  *
6668  * If the pattern hasn't changed from old_re, then old_re will be
6669  * returned.
6670  *
6671  * eng is the current engine. If that engine has an op_comp method, then
6672  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6673  * do the initial concatenation of arguments and pass on to the external
6674  * engine.
6675  *
6676  * If is_bare_re is not null, set it to a boolean indicating whether the
6677  * arg list reduced (after overloading) to a single bare regex which has
6678  * been returned (i.e. /$qr/).
6679  *
6680  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6681  *
6682  * pm_flags contains the PMf_* flags, typically based on those from the
6683  * pm_flags field of the related PMOP. Currently we're only interested in
6684  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6685  *
6686  * We can't allocate space until we know how big the compiled form will be,
6687  * but we can't compile it (and thus know how big it is) until we've got a
6688  * place to put the code.  So we cheat:  we compile it twice, once with code
6689  * generation turned off and size counting turned on, and once "for real".
6690  * This also means that we don't allocate space until we are sure that the
6691  * thing really will compile successfully, and we never have to move the
6692  * code and thus invalidate pointers into it.  (Note that it has to be in
6693  * one piece because free() must be able to free it all.) [NB: not true in perl]
6694  *
6695  * Beware that the optimization-preparation code in here knows about some
6696  * of the structure of the compiled regexp.  [I'll say.]
6697  */
6698
6699 REGEXP *
6700 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6701                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6702                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6703 {
6704     REGEXP *rx;
6705     struct regexp *r;
6706     regexp_internal *ri;
6707     STRLEN plen;
6708     char *exp;
6709     regnode *scan;
6710     I32 flags;
6711     SSize_t minlen = 0;
6712     U32 rx_flags;
6713     SV *pat;
6714     SV *code_blocksv = NULL;
6715     SV** new_patternp = patternp;
6716
6717     /* these are all flags - maybe they should be turned
6718      * into a single int with different bit masks */
6719     I32 sawlookahead = 0;
6720     I32 sawplus = 0;
6721     I32 sawopen = 0;
6722     I32 sawminmod = 0;
6723
6724     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6725     bool recompile = 0;
6726     bool runtime_code = 0;
6727     scan_data_t data;
6728     RExC_state_t RExC_state;
6729     RExC_state_t * const pRExC_state = &RExC_state;
6730 #ifdef TRIE_STUDY_OPT
6731     int restudied = 0;
6732     RExC_state_t copyRExC_state;
6733 #endif
6734     GET_RE_DEBUG_FLAGS_DECL;
6735
6736     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6737
6738     DEBUG_r(if (!PL_colorset) reginitcolors());
6739
6740     /* Initialize these here instead of as-needed, as is quick and avoids
6741      * having to test them each time otherwise */
6742     if (! PL_AboveLatin1) {
6743 #ifdef DEBUGGING
6744         char * dump_len_string;
6745 #endif
6746
6747         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6748         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6749         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6750         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6751         PL_HasMultiCharFold =
6752                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6753
6754         /* This is calculated here, because the Perl program that generates the
6755          * static global ones doesn't currently have access to
6756          * NUM_ANYOF_CODE_POINTS */
6757         PL_InBitmap = _new_invlist(2);
6758         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6759                                                     NUM_ANYOF_CODE_POINTS - 1);
6760 #ifdef DEBUGGING
6761         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6762         if (   ! dump_len_string
6763             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6764         {
6765             PL_dump_re_max_len = 0;
6766         }
6767 #endif
6768     }
6769
6770     pRExC_state->code_blocks = NULL;
6771     pRExC_state->num_code_blocks = 0;
6772
6773     if (is_bare_re)
6774         *is_bare_re = FALSE;
6775
6776     if (expr && (expr->op_type == OP_LIST ||
6777                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6778         /* allocate code_blocks if needed */
6779         OP *o;
6780         int ncode = 0;
6781
6782         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6783             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6784                 ncode++; /* count of DO blocks */
6785         if (ncode) {
6786             pRExC_state->num_code_blocks = ncode;
6787             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
6788         }
6789     }
6790
6791     if (!pat_count) {
6792         /* compile-time pattern with just OP_CONSTs and DO blocks */
6793
6794         int n;
6795         OP *o;
6796
6797         /* find how many CONSTs there are */
6798         assert(expr);
6799         n = 0;
6800         if (expr->op_type == OP_CONST)
6801             n = 1;
6802         else
6803             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6804                 if (o->op_type == OP_CONST)
6805                     n++;
6806             }
6807
6808         /* fake up an SV array */
6809
6810         assert(!new_patternp);
6811         Newx(new_patternp, n, SV*);
6812         SAVEFREEPV(new_patternp);
6813         pat_count = n;
6814
6815         n = 0;
6816         if (expr->op_type == OP_CONST)
6817             new_patternp[n] = cSVOPx_sv(expr);
6818         else
6819             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6820                 if (o->op_type == OP_CONST)
6821                     new_patternp[n++] = cSVOPo_sv;
6822             }
6823
6824     }
6825
6826     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6827         "Assembling pattern from %d elements%s\n", pat_count,
6828             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6829
6830     /* set expr to the first arg op */
6831
6832     if (pRExC_state->num_code_blocks
6833          && expr->op_type != OP_CONST)
6834     {
6835             expr = cLISTOPx(expr)->op_first;
6836             assert(   expr->op_type == OP_PUSHMARK
6837                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6838                    || expr->op_type == OP_PADRANGE);
6839             expr = OpSIBLING(expr);
6840     }
6841
6842     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6843                         expr, &recompile, NULL);
6844
6845     /* handle bare (possibly after overloading) regex: foo =~ $re */
6846     {
6847         SV *re = pat;
6848         if (SvROK(re))
6849             re = SvRV(re);
6850         if (SvTYPE(re) == SVt_REGEXP) {
6851             if (is_bare_re)
6852                 *is_bare_re = TRUE;
6853             SvREFCNT_inc(re);
6854             Safefree(pRExC_state->code_blocks);
6855             DEBUG_PARSE_r(Perl_re_printf( aTHX_
6856                 "Precompiled pattern%s\n",
6857                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6858
6859             return (REGEXP*)re;
6860         }
6861     }
6862
6863     exp = SvPV_nomg(pat, plen);
6864
6865     if (!eng->op_comp) {
6866         if ((SvUTF8(pat) && IN_BYTES)
6867                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6868         {
6869             /* make a temporary copy; either to convert to bytes,
6870              * or to avoid repeating get-magic / overloaded stringify */
6871             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6872                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6873         }
6874         Safefree(pRExC_state->code_blocks);
6875         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6876     }
6877
6878     /* ignore the utf8ness if the pattern is 0 length */
6879     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6880
6881     RExC_uni_semantics = 0;
6882     RExC_seen_unfolded_sharp_s = 0;
6883     RExC_contains_locale = 0;
6884     RExC_contains_i = 0;
6885     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
6886     pRExC_state->runtime_code_qr = NULL;
6887     RExC_frame_head= NULL;
6888     RExC_frame_last= NULL;
6889     RExC_frame_count= 0;
6890
6891     DEBUG_r({
6892         RExC_mysv1= sv_newmortal();
6893         RExC_mysv2= sv_newmortal();
6894     });
6895     DEBUG_COMPILE_r({
6896             SV *dsv= sv_newmortal();
6897             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6898             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
6899                           PL_colors[4],PL_colors[5],s);
6900         });
6901
6902   redo_first_pass:
6903     /* we jump here if we have to recompile, e.g., from upgrading the pattern
6904      * to utf8 */
6905
6906     if ((pm_flags & PMf_USE_RE_EVAL)
6907                 /* this second condition covers the non-regex literal case,
6908                  * i.e.  $foo =~ '(?{})'. */
6909                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6910     )
6911         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6912
6913     /* return old regex if pattern hasn't changed */
6914     /* XXX: note in the below we have to check the flags as well as the
6915      * pattern.
6916      *
6917      * Things get a touch tricky as we have to compare the utf8 flag
6918      * independently from the compile flags.  */
6919
6920     if (   old_re
6921         && !recompile
6922         && !!RX_UTF8(old_re) == !!RExC_utf8
6923         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
6924         && RX_PRECOMP(old_re)
6925         && RX_PRELEN(old_re) == plen
6926         && memEQ(RX_PRECOMP(old_re), exp, plen)
6927         && !runtime_code /* with runtime code, always recompile */ )
6928     {
6929         Safefree(pRExC_state->code_blocks);
6930         return old_re;
6931     }
6932
6933     rx_flags = orig_rx_flags;
6934
6935     if (rx_flags & PMf_FOLD) {
6936         RExC_contains_i = 1;
6937     }
6938     if (   initial_charset == REGEX_DEPENDS_CHARSET
6939         && (RExC_utf8 ||RExC_uni_semantics))
6940     {
6941
6942         /* Set to use unicode semantics if the pattern is in utf8 and has the
6943          * 'depends' charset specified, as it means unicode when utf8  */
6944         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6945     }
6946
6947     RExC_precomp = exp;
6948     RExC_precomp_adj = 0;
6949     RExC_flags = rx_flags;
6950     RExC_pm_flags = pm_flags;
6951
6952     if (runtime_code) {
6953         assert(TAINTING_get || !TAINT_get);
6954         if (TAINT_get)
6955             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
6956
6957         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
6958             /* whoops, we have a non-utf8 pattern, whilst run-time code
6959              * got compiled as utf8. Try again with a utf8 pattern */
6960             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6961                                     pRExC_state->num_code_blocks);
6962             goto redo_first_pass;
6963         }
6964     }
6965     assert(!pRExC_state->runtime_code_qr);
6966
6967     RExC_sawback = 0;
6968
6969     RExC_seen = 0;
6970     RExC_maxlen = 0;
6971     RExC_in_lookbehind = 0;
6972     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
6973     RExC_extralen = 0;
6974     RExC_override_recoding = 0;
6975 #ifdef EBCDIC
6976     RExC_recode_x_to_native = 0;
6977 #endif
6978     RExC_in_multi_char_class = 0;
6979
6980     /* First pass: determine size, legality. */
6981     RExC_parse = exp;
6982     RExC_start = RExC_adjusted_start = exp;
6983     RExC_end = exp + plen;
6984     RExC_precomp_end = RExC_end;
6985     RExC_naughty = 0;
6986     RExC_npar = 1;
6987     RExC_nestroot = 0;
6988     RExC_size = 0L;
6989     RExC_emit = (regnode *) &RExC_emit_dummy;
6990     RExC_whilem_seen = 0;
6991     RExC_open_parens = NULL;
6992     RExC_close_parens = NULL;
6993     RExC_end_op = NULL;
6994     RExC_paren_names = NULL;
6995 #ifdef DEBUGGING
6996     RExC_paren_name_list = NULL;
6997 #endif
6998     RExC_recurse = NULL;
6999     RExC_study_chunk_recursed = NULL;
7000     RExC_study_chunk_recursed_bytes= 0;
7001     RExC_recurse_count = 0;
7002     pRExC_state->code_index = 0;
7003
7004     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7005      * code makes sure the final byte is an uncounted NUL.  But should this
7006      * ever not be the case, lots of things could read beyond the end of the
7007      * buffer: loops like
7008      *      while(isFOO(*RExC_parse)) RExC_parse++;
7009      *      strchr(RExC_parse, "foo");
7010      * etc.  So it is worth noting. */
7011     assert(*RExC_end == '\0');
7012
7013     DEBUG_PARSE_r(
7014         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7015         RExC_lastnum=0;
7016         RExC_lastparse=NULL;
7017     );
7018     /* reg may croak on us, not giving us a chance to free
7019        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
7020        need it to survive as long as the regexp (qr/(?{})/).
7021        We must check that code_blocksv is not already set, because we may
7022        have jumped back to restart the sizing pass. */
7023     if (pRExC_state->code_blocks && !code_blocksv) {
7024         code_blocksv = newSV_type(SVt_PV);
7025         SAVEFREESV(code_blocksv);
7026         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
7027         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
7028     }
7029     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7030         /* It's possible to write a regexp in ascii that represents Unicode
7031         codepoints outside of the byte range, such as via \x{100}. If we
7032         detect such a sequence we have to convert the entire pattern to utf8
7033         and then recompile, as our sizing calculation will have been based
7034         on 1 byte == 1 character, but we will need to use utf8 to encode
7035         at least some part of the pattern, and therefore must convert the whole
7036         thing.
7037         -- dmq */
7038         if (flags & RESTART_PASS1) {
7039             if (flags & NEED_UTF8) {
7040                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7041                                     pRExC_state->num_code_blocks);
7042             }
7043             else {
7044                 DEBUG_PARSE_r(Perl_re_printf( aTHX_
7045                 "Need to redo pass 1\n"));
7046             }
7047
7048             goto redo_first_pass;
7049         }
7050         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#"UVxf"", (UV) flags);
7051     }
7052     if (code_blocksv)
7053         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
7054
7055     DEBUG_PARSE_r({
7056         Perl_re_printf( aTHX_
7057             "Required size %"IVdf" nodes\n"
7058             "Starting second pass (creation)\n",
7059             (IV)RExC_size);
7060         RExC_lastnum=0;
7061         RExC_lastparse=NULL;
7062     });
7063
7064     /* The first pass could have found things that force Unicode semantics */
7065     if ((RExC_utf8 || RExC_uni_semantics)
7066          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7067     {
7068         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7069     }
7070
7071     /* Small enough for pointer-storage convention?
7072        If extralen==0, this means that we will not need long jumps. */
7073     if (RExC_size >= 0x10000L && RExC_extralen)
7074         RExC_size += RExC_extralen;
7075     else
7076         RExC_extralen = 0;
7077     if (RExC_whilem_seen > 15)
7078         RExC_whilem_seen = 15;
7079
7080     /* Allocate space and zero-initialize. Note, the two step process
7081        of zeroing when in debug mode, thus anything assigned has to
7082        happen after that */
7083     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7084     r = ReANY(rx);
7085     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7086          char, regexp_internal);
7087     if ( r == NULL || ri == NULL )
7088         FAIL("Regexp out of space");
7089 #ifdef DEBUGGING
7090     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7091     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7092          char);
7093 #else
7094     /* bulk initialize base fields with 0. */
7095     Zero(ri, sizeof(regexp_internal), char);
7096 #endif
7097
7098     /* non-zero initialization begins here */
7099     RXi_SET( r, ri );
7100     r->engine= eng;
7101     r->extflags = rx_flags;
7102     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7103
7104     if (pm_flags & PMf_IS_QR) {
7105         ri->code_blocks = pRExC_state->code_blocks;
7106         ri->num_code_blocks = pRExC_state->num_code_blocks;
7107     }
7108     else
7109     {
7110         int n;
7111         for (n = 0; n < pRExC_state->num_code_blocks; n++)
7112             if (pRExC_state->code_blocks[n].src_regex)
7113                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
7114         if(pRExC_state->code_blocks)
7115             SAVEFREEPV(pRExC_state->code_blocks); /* often null */
7116     }
7117
7118     {
7119         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7120         bool has_charset = (get_regex_charset(r->extflags)
7121                                                     != REGEX_DEPENDS_CHARSET);
7122
7123         /* The caret is output if there are any defaults: if not all the STD
7124          * flags are set, or if no character set specifier is needed */
7125         bool has_default =
7126                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7127                     || ! has_charset);
7128         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7129                                                    == REG_RUN_ON_COMMENT_SEEN);
7130         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7131                             >> RXf_PMf_STD_PMMOD_SHIFT);
7132         const char *fptr = STD_PAT_MODS;        /*"msixn"*/
7133         char *p;
7134
7135         /* We output all the necessary flags; we never output a minus, as all
7136          * those are defaults, so are
7137          * covered by the caret */
7138         const STRLEN wraplen = plen + has_p + has_runon
7139             + has_default       /* If needs a caret */
7140             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7141
7142                 /* If needs a character set specifier */
7143             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7144             + (sizeof("(?:)") - 1);
7145
7146         /* make sure PL_bitcount bounds not exceeded */
7147         assert(sizeof(STD_PAT_MODS) <= 8);
7148
7149         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
7150         r->xpv_len_u.xpvlenu_pv = p;
7151         if (RExC_utf8)
7152             SvFLAGS(rx) |= SVf_UTF8;
7153         *p++='('; *p++='?';
7154
7155         /* If a default, cover it using the caret */
7156         if (has_default) {
7157             *p++= DEFAULT_PAT_MOD;
7158         }
7159         if (has_charset) {
7160             STRLEN len;
7161             const char* const name = get_regex_charset_name(r->extflags, &len);
7162             Copy(name, p, len, char);
7163             p += len;
7164         }
7165         if (has_p)
7166             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7167         {
7168             char ch;
7169             while((ch = *fptr++)) {
7170                 if(reganch & 1)
7171                     *p++ = ch;
7172                 reganch >>= 1;
7173             }
7174         }
7175
7176         *p++ = ':';
7177         Copy(RExC_precomp, p, plen, char);
7178         assert ((RX_WRAPPED(rx) - p) < 16);
7179         r->pre_prefix = p - RX_WRAPPED(rx);
7180         p += plen;
7181         if (has_runon)
7182             *p++ = '\n';
7183         *p++ = ')';
7184         *p = 0;
7185         SvCUR_set(rx, p - RX_WRAPPED(rx));
7186     }
7187
7188     r->intflags = 0;
7189     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7190
7191     /* Useful during FAIL. */
7192 #ifdef RE_TRACK_PATTERN_OFFSETS
7193     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7194     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7195                           "%s %"UVuf" bytes for offset annotations.\n",
7196                           ri->u.offsets ? "Got" : "Couldn't get",
7197                           (UV)((2*RExC_size+1) * sizeof(U32))));
7198 #endif
7199     SetProgLen(ri,RExC_size);
7200     RExC_rx_sv = rx;
7201     RExC_rx = r;
7202     RExC_rxi = ri;
7203
7204     /* Second pass: emit code. */
7205     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7206     RExC_pm_flags = pm_flags;
7207     RExC_parse = exp;
7208     RExC_end = exp + plen;
7209     RExC_naughty = 0;
7210     RExC_emit_start = ri->program;
7211     RExC_emit = ri->program;
7212     RExC_emit_bound = ri->program + RExC_size + 1;
7213     pRExC_state->code_index = 0;
7214
7215     *((char*) RExC_emit++) = (char) REG_MAGIC;
7216     /* setup various meta data about recursion, this all requires
7217      * RExC_npar to be correctly set, and a bit later on we clear it */
7218     if (RExC_seen & REG_RECURSE_SEEN) {
7219         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7220             "%*s%*s Setting up open/close parens\n",
7221                   22, "|    |", (int)(0 * 2 + 1), ""));
7222
7223         /* setup RExC_open_parens, which holds the address of each
7224          * OPEN tag, and to make things simpler for the 0 index
7225          * the start of the program - this is used later for offsets */
7226         Newxz(RExC_open_parens, RExC_npar,regnode *);
7227         SAVEFREEPV(RExC_open_parens);
7228         RExC_open_parens[0] = RExC_emit;
7229
7230         /* setup RExC_close_parens, which holds the address of each
7231          * CLOSE tag, and to make things simpler for the 0 index
7232          * the end of the program - this is used later for offsets */
7233         Newxz(RExC_close_parens, RExC_npar,regnode *);
7234         SAVEFREEPV(RExC_close_parens);
7235         /* we dont know where end op starts yet, so we dont
7236          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7237
7238         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7239          * So its 1 if there are no parens. */
7240         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7241                                          ((RExC_npar & 0x07) != 0);
7242         Newx(RExC_study_chunk_recursed,
7243              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7244         SAVEFREEPV(RExC_study_chunk_recursed);
7245     }
7246     RExC_npar = 1;
7247     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7248         ReREFCNT_dec(rx);
7249         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags);
7250     }
7251     DEBUG_OPTIMISE_r(
7252         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7253     );
7254
7255     /* XXXX To minimize changes to RE engine we always allocate
7256        3-units-long substrs field. */
7257     Newx(r->substrs, 1, struct reg_substr_data);
7258     if (RExC_recurse_count) {
7259         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
7260         SAVEFREEPV(RExC_recurse);
7261     }
7262
7263   reStudy:
7264     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7265     DEBUG_r(
7266         RExC_study_chunk_recursed_count= 0;
7267     );
7268     Zero(r->substrs, 1, struct reg_substr_data);
7269     if (RExC_study_chunk_recursed) {
7270         Zero(RExC_study_chunk_recursed,
7271              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7272     }
7273
7274
7275 #ifdef TRIE_STUDY_OPT
7276     if (!restudied) {
7277         StructCopy(&zero_scan_data, &data, scan_data_t);
7278         copyRExC_state = RExC_state;
7279     } else {
7280         U32 seen=RExC_seen;
7281         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7282
7283         RExC_state = copyRExC_state;
7284         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7285             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7286         else
7287             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7288         StructCopy(&zero_scan_data, &data, scan_data_t);
7289     }
7290 #else
7291     StructCopy(&zero_scan_data, &data, scan_data_t);
7292 #endif
7293
7294     /* Dig out information for optimizations. */
7295     r->extflags = RExC_flags; /* was pm_op */
7296     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7297
7298     if (UTF)
7299         SvUTF8_on(rx);  /* Unicode in it? */
7300     ri->regstclass = NULL;
7301     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7302         r->intflags |= PREGf_NAUGHTY;
7303     scan = ri->program + 1;             /* First BRANCH. */
7304
7305     /* testing for BRANCH here tells us whether there is "must appear"
7306        data in the pattern. If there is then we can use it for optimisations */
7307     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7308                                                   */
7309         SSize_t fake;
7310         STRLEN longest_float_length, longest_fixed_length;
7311         regnode_ssc ch_class; /* pointed to by data */
7312         int stclass_flag;
7313         SSize_t last_close = 0; /* pointed to by data */
7314         regnode *first= scan;
7315         regnode *first_next= regnext(first);
7316         /*
7317          * Skip introductions and multiplicators >= 1
7318          * so that we can extract the 'meat' of the pattern that must
7319          * match in the large if() sequence following.
7320          * NOTE that EXACT is NOT covered here, as it is normally
7321          * picked up by the optimiser separately.
7322          *
7323          * This is unfortunate as the optimiser isnt handling lookahead
7324          * properly currently.
7325          *
7326          */
7327         while ((OP(first) == OPEN && (sawopen = 1)) ||
7328                /* An OR of *one* alternative - should not happen now. */
7329             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7330             /* for now we can't handle lookbehind IFMATCH*/
7331             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7332             (OP(first) == PLUS) ||
7333             (OP(first) == MINMOD) ||
7334                /* An {n,m} with n>0 */
7335             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7336             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7337         {
7338                 /*
7339                  * the only op that could be a regnode is PLUS, all the rest
7340                  * will be regnode_1 or regnode_2.
7341                  *
7342                  * (yves doesn't think this is true)
7343                  */
7344                 if (OP(first) == PLUS)
7345                     sawplus = 1;
7346                 else {
7347                     if (OP(first) == MINMOD)
7348                         sawminmod = 1;
7349                     first += regarglen[OP(first)];
7350                 }
7351                 first = NEXTOPER(first);
7352                 first_next= regnext(first);
7353         }
7354
7355         /* Starting-point info. */
7356       again:
7357         DEBUG_PEEP("first:",first,0);
7358         /* Ignore EXACT as we deal with it later. */
7359         if (PL_regkind[OP(first)] == EXACT) {
7360             if (OP(first) == EXACT || OP(first) == EXACTL)
7361                 NOOP;   /* Empty, get anchored substr later. */
7362             else
7363                 ri->regstclass = first;
7364         }
7365 #ifdef TRIE_STCLASS
7366         else if (PL_regkind[OP(first)] == TRIE &&
7367                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7368         {
7369             /* this can happen only on restudy */
7370             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7371         }
7372 #endif
7373         else if (REGNODE_SIMPLE(OP(first)))
7374             ri->regstclass = first;
7375         else if (PL_regkind[OP(first)] == BOUND ||
7376                  PL_regkind[OP(first)] == NBOUND)
7377             ri->regstclass = first;
7378         else if (PL_regkind[OP(first)] == BOL) {
7379             r->intflags |= (OP(first) == MBOL
7380                            ? PREGf_ANCH_MBOL
7381                            : PREGf_ANCH_SBOL);
7382             first = NEXTOPER(first);
7383             goto again;
7384         }
7385         else if (OP(first) == GPOS) {
7386             r->intflags |= PREGf_ANCH_GPOS;
7387             first = NEXTOPER(first);
7388             goto again;
7389         }
7390         else if ((!sawopen || !RExC_sawback) &&
7391             !sawlookahead &&
7392             (OP(first) == STAR &&
7393             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7394             !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
7395         {
7396             /* turn .* into ^.* with an implied $*=1 */
7397             const int type =
7398                 (OP(NEXTOPER(first)) == REG_ANY)
7399                     ? PREGf_ANCH_MBOL
7400                     : PREGf_ANCH_SBOL;
7401             r->intflags |= (type | PREGf_IMPLICIT);
7402             first = NEXTOPER(first);
7403             goto again;
7404         }
7405         if (sawplus && !sawminmod && !sawlookahead
7406             && (!sawopen || !RExC_sawback)
7407             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
7408             /* x+ must match at the 1st pos of run of x's */
7409             r->intflags |= PREGf_SKIP;
7410
7411         /* Scan is after the zeroth branch, first is atomic matcher. */
7412 #ifdef TRIE_STUDY_OPT
7413         DEBUG_PARSE_r(
7414             if (!restudied)
7415                 Perl_re_printf( aTHX_  "first at %"IVdf"\n",
7416                               (IV)(first - scan + 1))
7417         );
7418 #else
7419         DEBUG_PARSE_r(
7420             Perl_re_printf( aTHX_  "first at %"IVdf"\n",
7421                 (IV)(first - scan + 1))
7422         );
7423 #endif
7424
7425
7426         /*
7427         * If there's something expensive in the r.e., find the
7428         * longest literal string that must appear and make it the
7429         * regmust.  Resolve ties in favor of later strings, since
7430         * the regstart check works with the beginning of the r.e.
7431         * and avoiding duplication strengthens checking.  Not a
7432         * strong reason, but sufficient in the absence of others.
7433         * [Now we resolve ties in favor of the earlier string if
7434         * it happens that c_offset_min has been invalidated, since the
7435         * earlier string may buy us something the later one won't.]
7436         */
7437
7438         data.longest_fixed = newSVpvs("");
7439         data.longest_float = newSVpvs("");
7440         data.last_found = newSVpvs("");
7441         data.longest = &(data.longest_fixed);
7442         ENTER_with_name("study_chunk");
7443         SAVEFREESV(data.longest_fixed);
7444         SAVEFREESV(data.longest_float);
7445         SAVEFREESV(data.last_found);
7446         first = scan;
7447         if (!ri->regstclass) {
7448             ssc_init(pRExC_state, &ch_class);
7449             data.start_class = &ch_class;
7450             stclass_flag = SCF_DO_STCLASS_AND;
7451         } else                          /* XXXX Check for BOUND? */
7452             stclass_flag = 0;
7453         data.last_closep = &last_close;
7454
7455         DEBUG_RExC_seen();
7456         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7457                              scan + RExC_size, /* Up to end */
7458             &data, -1, 0, NULL,
7459             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7460                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7461             0);
7462
7463
7464         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7465
7466
7467         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
7468              && data.last_start_min == 0 && data.last_end > 0
7469              && !RExC_seen_zerolen
7470              && !(RExC_seen & REG_VERBARG_SEEN)
7471              && !(RExC_seen & REG_GPOS_SEEN)
7472         ){
7473             r->extflags |= RXf_CHECK_ALL;
7474         }
7475         scan_commit(pRExC_state, &data,&minlen,0);
7476
7477         longest_float_length = CHR_SVLEN(data.longest_float);
7478
7479         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
7480                    && data.offset_fixed == data.offset_float_min
7481                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
7482             && S_setup_longest (aTHX_ pRExC_state,
7483                                     data.longest_float,
7484                                     &(r->float_utf8),
7485                                     &(r->float_substr),
7486                                     &(r->float_end_shift),
7487                                     data.lookbehind_float,
7488                                     data.offset_float_min,
7489                                     data.minlen_float,
7490                                     longest_float_length,
7491                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
7492                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
7493         {
7494             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
7495             r->float_max_offset = data.offset_float_max;
7496             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
7497                 r->float_max_offset -= data.lookbehind_float;
7498             SvREFCNT_inc_simple_void_NN(data.longest_float);
7499         }
7500         else {
7501             r->float_substr = r->float_utf8 = NULL;
7502             longest_float_length = 0;
7503         }
7504
7505         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
7506
7507         if (S_setup_longest (aTHX_ pRExC_state,
7508                                 data.longest_fixed,
7509                                 &(r->anchored_utf8),
7510                                 &(r->anchored_substr),
7511                                 &(r->anchored_end_shift),
7512                                 data.lookbehind_fixed,
7513                                 data.offset_fixed,
7514                                 data.minlen_fixed,
7515                                 longest_fixed_length,
7516                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7517                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7518         {
7519             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7520             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7521         }
7522         else {
7523             r->anchored_substr = r->anchored_utf8 = NULL;
7524             longest_fixed_length = 0;
7525         }
7526         LEAVE_with_name("study_chunk");
7527
7528         if (ri->regstclass
7529             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7530             ri->regstclass = NULL;
7531
7532         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7533             && stclass_flag
7534             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7535             && is_ssc_worth_it(pRExC_state, data.start_class))
7536         {
7537             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7538
7539             ssc_finalize(pRExC_state, data.start_class);
7540
7541             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7542             StructCopy(data.start_class,
7543                        (regnode_ssc*)RExC_rxi->data->data[n],
7544                        regnode_ssc);
7545             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7546             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7547             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7548                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7549                       Perl_re_printf( aTHX_
7550                                     "synthetic stclass \"%s\".\n",
7551                                     SvPVX_const(sv));});
7552             data.start_class = NULL;
7553         }
7554
7555         /* A temporary algorithm prefers floated substr to fixed one to dig
7556          * more info. */
7557         if (longest_fixed_length > longest_float_length) {
7558             r->substrs->check_ix = 0;
7559             r->check_end_shift = r->anchored_end_shift;
7560             r->check_substr = r->anchored_substr;
7561             r->check_utf8 = r->anchored_utf8;
7562             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7563             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7564                 r->intflags |= PREGf_NOSCAN;
7565         }
7566         else {
7567             r->substrs->check_ix = 1;
7568             r->check_end_shift = r->float_end_shift;
7569             r->check_substr = r->float_substr;
7570             r->check_utf8 = r->float_utf8;
7571             r->check_offset_min = r->float_min_offset;
7572             r->check_offset_max = r->float_max_offset;
7573         }
7574         if ((r->check_substr || r->check_utf8) ) {
7575             r->extflags |= RXf_USE_INTUIT;
7576             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7577                 r->extflags |= RXf_INTUIT_TAIL;
7578         }
7579         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7580
7581         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7582         if ( (STRLEN)minlen < longest_float_length )
7583             minlen= longest_float_length;
7584         if ( (STRLEN)minlen < longest_fixed_length )
7585             minlen= longest_fixed_length;
7586         */
7587     }
7588     else {
7589         /* Several toplevels. Best we can is to set minlen. */
7590         SSize_t fake;
7591         regnode_ssc ch_class;
7592         SSize_t last_close = 0;
7593
7594         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7595
7596         scan = ri->program + 1;
7597         ssc_init(pRExC_state, &ch_class);
7598         data.start_class = &ch_class;
7599         data.last_closep = &last_close;
7600
7601         DEBUG_RExC_seen();
7602         minlen = study_chunk(pRExC_state,
7603             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7604             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7605                                                       ? SCF_TRIE_DOING_RESTUDY
7606                                                       : 0),
7607             0);
7608
7609         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7610
7611         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7612                 = r->float_substr = r->float_utf8 = NULL;
7613
7614         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7615             && is_ssc_worth_it(pRExC_state, data.start_class))
7616         {
7617             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7618
7619             ssc_finalize(pRExC_state, data.start_class);
7620
7621             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7622             StructCopy(data.start_class,
7623                        (regnode_ssc*)RExC_rxi->data->data[n],
7624                        regnode_ssc);
7625             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7626             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7627             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7628                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7629                       Perl_re_printf( aTHX_
7630                                     "synthetic stclass \"%s\".\n",
7631                                     SvPVX_const(sv));});
7632             data.start_class = NULL;
7633         }
7634     }
7635
7636     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7637         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7638         r->maxlen = REG_INFTY;
7639     }
7640     else {
7641         r->maxlen = RExC_maxlen;
7642     }
7643
7644     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7645        the "real" pattern. */
7646     DEBUG_OPTIMISE_r({
7647         Perl_re_printf( aTHX_ "minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%"IVdf"\n",
7648                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7649     });
7650     r->minlenret = minlen;
7651     if (r->minlen < minlen)
7652         r->minlen = minlen;
7653
7654     if (RExC_seen & REG_RECURSE_SEEN ) {
7655         r->intflags |= PREGf_RECURSE_SEEN;
7656         Newxz(r->recurse_locinput, r->nparens + 1, char *);
7657     }
7658     if (RExC_seen & REG_GPOS_SEEN)
7659         r->intflags |= PREGf_GPOS_SEEN;
7660     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7661         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7662                                                 lookbehind */
7663     if (pRExC_state->num_code_blocks)
7664         r->extflags |= RXf_EVAL_SEEN;
7665     if (RExC_seen & REG_VERBARG_SEEN)
7666     {
7667         r->intflags |= PREGf_VERBARG_SEEN;
7668         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7669     }
7670     if (RExC_seen & REG_CUTGROUP_SEEN)
7671         r->intflags |= PREGf_CUTGROUP_SEEN;
7672     if (pm_flags & PMf_USE_RE_EVAL)
7673         r->intflags |= PREGf_USE_RE_EVAL;
7674     if (RExC_paren_names)
7675         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7676     else
7677         RXp_PAREN_NAMES(r) = NULL;
7678
7679     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7680      * so it can be used in pp.c */
7681     if (r->intflags & PREGf_ANCH)
7682         r->extflags |= RXf_IS_ANCHORED;
7683
7684
7685     {
7686         /* this is used to identify "special" patterns that might result
7687          * in Perl NOT calling the regex engine and instead doing the match "itself",
7688          * particularly special cases in split//. By having the regex compiler
7689          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7690          * we avoid weird issues with equivalent patterns resulting in different behavior,
7691          * AND we allow non Perl engines to get the same optimizations by the setting the
7692          * flags appropriately - Yves */
7693         regnode *first = ri->program + 1;
7694         U8 fop = OP(first);
7695         regnode *next = regnext(first);
7696         U8 nop = OP(next);
7697
7698         if (PL_regkind[fop] == NOTHING && nop == END)
7699             r->extflags |= RXf_NULL;
7700         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7701             /* when fop is SBOL first->flags will be true only when it was
7702              * produced by parsing /\A/, and not when parsing /^/. This is
7703              * very important for the split code as there we want to
7704              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7705              * See rt #122761 for more details. -- Yves */
7706             r->extflags |= RXf_START_ONLY;
7707         else if (fop == PLUS
7708                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7709                  && nop == END)
7710             r->extflags |= RXf_WHITE;
7711         else if ( r->extflags & RXf_SPLIT
7712                   && (fop == EXACT || fop == EXACTL)
7713                   && STR_LEN(first) == 1
7714                   && *(STRING(first)) == ' '
7715                   && nop == END )
7716             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7717
7718     }
7719
7720     if (RExC_contains_locale) {
7721         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7722     }
7723
7724 #ifdef DEBUGGING
7725     if (RExC_paren_names) {
7726         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7727         ri->data->data[ri->name_list_idx]
7728                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7729     } else
7730 #endif
7731     ri->name_list_idx = 0;
7732
7733     while ( RExC_recurse_count > 0 ) {
7734         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7735         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7736     }
7737
7738     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7739     /* assume we don't need to swap parens around before we match */
7740     DEBUG_TEST_r({
7741         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7742             (unsigned long)RExC_study_chunk_recursed_count);
7743     });
7744     DEBUG_DUMP_r({
7745         DEBUG_RExC_seen();
7746         Perl_re_printf( aTHX_ "Final program:\n");
7747         regdump(r);
7748     });
7749 #ifdef RE_TRACK_PATTERN_OFFSETS
7750     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7751         const STRLEN len = ri->u.offsets[0];
7752         STRLEN i;
7753         GET_RE_DEBUG_FLAGS_DECL;
7754         Perl_re_printf( aTHX_
7755                       "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
7756         for (i = 1; i <= len; i++) {
7757             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7758                 Perl_re_printf( aTHX_  "%"UVuf":%"UVuf"[%"UVuf"] ",
7759                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7760             }
7761         Perl_re_printf( aTHX_  "\n");
7762     });
7763 #endif
7764
7765 #ifdef USE_ITHREADS
7766     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7767      * by setting the regexp SV to readonly-only instead. If the
7768      * pattern's been recompiled, the USEDness should remain. */
7769     if (old_re && SvREADONLY(old_re))
7770         SvREADONLY_on(rx);
7771 #endif
7772     return rx;
7773 }
7774
7775
7776 SV*
7777 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7778                     const U32 flags)
7779 {
7780     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7781
7782     PERL_UNUSED_ARG(value);
7783
7784     if (flags & RXapif_FETCH) {
7785         return reg_named_buff_fetch(rx, key, flags);
7786     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7787         Perl_croak_no_modify();
7788         return NULL;
7789     } else if (flags & RXapif_EXISTS) {
7790         return reg_named_buff_exists(rx, key, flags)
7791             ? &PL_sv_yes
7792             : &PL_sv_no;
7793     } else if (flags & RXapif_REGNAMES) {
7794         return reg_named_buff_all(rx, flags);
7795     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7796         return reg_named_buff_scalar(rx, flags);
7797     } else {
7798         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7799         return NULL;
7800     }
7801 }
7802
7803 SV*
7804 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7805                          const U32 flags)
7806 {
7807     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7808     PERL_UNUSED_ARG(lastkey);
7809
7810     if (flags & RXapif_FIRSTKEY)
7811         return reg_named_buff_firstkey(rx, flags);
7812     else if (flags & RXapif_NEXTKEY)
7813         return reg_named_buff_nextkey(rx, flags);
7814     else {
7815         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7816                                             (int)flags);
7817         return NULL;
7818     }
7819 }
7820
7821 SV*
7822 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7823                           const U32 flags)
7824 {
7825     AV *retarray = NULL;
7826     SV *ret;
7827     struct regexp *const rx = ReANY(r);
7828
7829     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7830
7831     if (flags & RXapif_ALL)
7832         retarray=newAV();
7833
7834     if (rx && RXp_PAREN_NAMES(rx)) {
7835         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7836         if (he_str) {
7837             IV i;
7838             SV* sv_dat=HeVAL(he_str);
7839             I32 *nums=(I32*)SvPVX(sv_dat);
7840             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7841                 if ((I32)(rx->nparens) >= nums[i]
7842                     && rx->offs[nums[i]].start != -1
7843                     && rx->offs[nums[i]].end != -1)
7844                 {
7845                     ret = newSVpvs("");
7846                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7847                     if (!retarray)
7848                         return ret;
7849                 } else {
7850                     if (retarray)
7851                         ret = newSVsv(&PL_sv_undef);
7852                 }
7853                 if (retarray)
7854                     av_push(retarray, ret);
7855             }
7856             if (retarray)
7857                 return newRV_noinc(MUTABLE_SV(retarray));
7858         }
7859     }
7860     return NULL;
7861 }
7862
7863 bool
7864 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7865                            const U32 flags)
7866 {
7867     struct regexp *const rx = ReANY(r);
7868
7869     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7870
7871     if (rx && RXp_PAREN_NAMES(rx)) {
7872         if (flags & RXapif_ALL) {
7873             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7874         } else {
7875             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7876             if (sv) {
7877                 SvREFCNT_dec_NN(sv);
7878                 return TRUE;
7879             } else {
7880                 return FALSE;
7881             }
7882         }
7883     } else {
7884         return FALSE;
7885     }
7886 }
7887
7888 SV*
7889 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7890 {
7891     struct regexp *const rx = ReANY(r);
7892
7893     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7894
7895     if ( rx && RXp_PAREN_NAMES(rx) ) {
7896         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7897
7898         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7899     } else {
7900         return FALSE;
7901     }
7902 }
7903
7904 SV*
7905 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7906 {
7907     struct regexp *const rx = ReANY(r);
7908     GET_RE_DEBUG_FLAGS_DECL;
7909
7910     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7911
7912     if (rx && RXp_PAREN_NAMES(rx)) {
7913         HV *hv = RXp_PAREN_NAMES(rx);
7914         HE *temphe;
7915         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7916             IV i;
7917             IV parno = 0;
7918             SV* sv_dat = HeVAL(temphe);
7919             I32 *nums = (I32*)SvPVX(sv_dat);
7920             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7921                 if ((I32)(rx->lastparen) >= nums[i] &&
7922                     rx->offs[nums[i]].start != -1 &&
7923                     rx->offs[nums[i]].end != -1)
7924                 {
7925                     parno = nums[i];
7926                     break;
7927                 }
7928             }
7929             if (parno || flags & RXapif_ALL) {
7930                 return newSVhek(HeKEY_hek(temphe));
7931             }
7932         }
7933     }
7934     return NULL;
7935 }
7936
7937 SV*
7938 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
7939 {
7940     SV *ret;
7941     AV *av;
7942     SSize_t length;
7943     struct regexp *const rx = ReANY(r);
7944
7945     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
7946
7947     if (rx && RXp_PAREN_NAMES(rx)) {
7948         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
7949             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
7950         } else if (flags & RXapif_ONE) {
7951             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
7952             av = MUTABLE_AV(SvRV(ret));
7953             length = av_tindex(av);
7954             SvREFCNT_dec_NN(ret);
7955             return newSViv(length + 1);
7956         } else {
7957             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
7958                                                 (int)flags);
7959             return NULL;
7960         }
7961     }
7962     return &PL_sv_undef;
7963 }
7964
7965 SV*
7966 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
7967 {
7968     struct regexp *const rx = ReANY(r);
7969     AV *av = newAV();
7970
7971     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
7972
7973     if (rx && RXp_PAREN_NAMES(rx)) {
7974         HV *hv= RXp_PAREN_NAMES(rx);
7975         HE *temphe;
7976         (void)hv_iterinit(hv);
7977         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7978             IV i;
7979             IV parno = 0;
7980             SV* sv_dat = HeVAL(temphe);
7981             I32 *nums = (I32*)SvPVX(sv_dat);
7982             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7983                 if ((I32)(rx->lastparen) >= nums[i] &&
7984                     rx->offs[nums[i]].start != -1 &&
7985                     rx->offs[nums[i]].end != -1)
7986                 {
7987                     parno = nums[i];
7988                     break;
7989                 }
7990             }
7991             if (parno || flags & RXapif_ALL) {
7992                 av_push(av, newSVhek(HeKEY_hek(temphe)));
7993             }
7994         }
7995     }
7996
7997     return newRV_noinc(MUTABLE_SV(av));
7998 }
7999
8000 void
8001 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8002                              SV * const sv)
8003 {
8004     struct regexp *const rx = ReANY(r);
8005     char *s = NULL;
8006     SSize_t i = 0;
8007     SSize_t s1, t1;
8008     I32 n = paren;
8009
8010     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8011
8012     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8013            || n == RX_BUFF_IDX_CARET_FULLMATCH
8014            || n == RX_BUFF_IDX_CARET_POSTMATCH
8015        )
8016     {
8017         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8018         if (!keepcopy) {
8019             /* on something like
8020              *    $r = qr/.../;
8021              *    /$qr/p;
8022              * the KEEPCOPY is set on the PMOP rather than the regex */
8023             if (PL_curpm && r == PM_GETRE(PL_curpm))
8024                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8025         }
8026         if (!keepcopy)
8027             goto ret_undef;
8028     }
8029
8030     if (!rx->subbeg)
8031         goto ret_undef;
8032
8033     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8034         /* no need to distinguish between them any more */
8035         n = RX_BUFF_IDX_FULLMATCH;
8036
8037     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8038         && rx->offs[0].start != -1)
8039     {
8040         /* $`, ${^PREMATCH} */
8041         i = rx->offs[0].start;
8042         s = rx->subbeg;
8043     }
8044     else
8045     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8046         && rx->offs[0].end != -1)
8047     {
8048         /* $', ${^POSTMATCH} */
8049         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8050         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8051     }
8052     else
8053     if ( 0 <= n && n <= (I32)rx->nparens &&
8054         (s1 = rx->offs[n].start) != -1 &&
8055         (t1 = rx->offs[n].end) != -1)
8056     {
8057         /* $&, ${^MATCH},  $1 ... */
8058         i = t1 - s1;
8059         s = rx->subbeg + s1 - rx->suboffset;
8060     } else {
8061         goto ret_undef;
8062     }
8063
8064     assert(s >= rx->subbeg);
8065     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8066     if (i >= 0) {
8067 #ifdef NO_TAINT_SUPPORT
8068         sv_setpvn(sv, s, i);
8069 #else
8070         const int oldtainted = TAINT_get;
8071         TAINT_NOT;
8072         sv_setpvn(sv, s, i);
8073         TAINT_set(oldtainted);
8074 #endif
8075         if (RXp_MATCH_UTF8(rx))
8076             SvUTF8_on(sv);
8077         else
8078             SvUTF8_off(sv);
8079         if (TAINTING_get) {
8080             if (RXp_MATCH_TAINTED(rx)) {
8081                 if (SvTYPE(sv) >= SVt_PVMG) {
8082                     MAGIC* const mg = SvMAGIC(sv);
8083                     MAGIC* mgt;
8084                     TAINT;
8085                     SvMAGIC_set(sv, mg->mg_moremagic);
8086                     SvTAINT(sv);
8087                     if ((mgt = SvMAGIC(sv))) {
8088                         mg->mg_moremagic = mgt;
8089                         SvMAGIC_set(sv, mg);
8090                     }
8091                 } else {
8092                     TAINT;
8093                     SvTAINT(sv);
8094                 }
8095             } else
8096                 SvTAINTED_off(sv);
8097         }
8098     } else {
8099       ret_undef:
8100         sv_setsv(sv,&PL_sv_undef);
8101         return;
8102     }
8103 }
8104
8105 void
8106 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8107                                                          SV const * const value)
8108 {
8109     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8110
8111     PERL_UNUSED_ARG(rx);
8112     PERL_UNUSED_ARG(paren);
8113     PERL_UNUSED_ARG(value);
8114
8115     if (!PL_localizing)
8116         Perl_croak_no_modify();
8117 }
8118
8119 I32
8120 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8121                               const I32 paren)
8122 {
8123     struct regexp *const rx = ReANY(r);
8124     I32 i;
8125     I32 s1, t1;
8126
8127     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8128
8129     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8130         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8131         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8132     )
8133     {
8134         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8135         if (!keepcopy) {
8136             /* on something like
8137              *    $r = qr/.../;
8138              *    /$qr/p;
8139              * the KEEPCOPY is set on the PMOP rather than the regex */
8140             if (PL_curpm && r == PM_GETRE(PL_curpm))
8141                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8142         }
8143         if (!keepcopy)
8144             goto warn_undef;
8145     }
8146
8147     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8148     switch (paren) {
8149       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8150       case RX_BUFF_IDX_PREMATCH:       /* $` */
8151         if (rx->offs[0].start != -1) {
8152                         i = rx->offs[0].start;
8153                         if (i > 0) {
8154                                 s1 = 0;
8155                                 t1 = i;
8156                                 goto getlen;
8157                         }
8158             }
8159         return 0;
8160
8161       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8162       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8163             if (rx->offs[0].end != -1) {
8164                         i = rx->sublen - rx->offs[0].end;
8165                         if (i > 0) {
8166                                 s1 = rx->offs[0].end;
8167                                 t1 = rx->sublen;
8168                                 goto getlen;
8169                         }
8170             }
8171         return 0;
8172
8173       default: /* $& / ${^MATCH}, $1, $2, ... */
8174             if (paren <= (I32)rx->nparens &&
8175             (s1 = rx->offs[paren].start) != -1 &&
8176             (t1 = rx->offs[paren].end) != -1)
8177             {
8178             i = t1 - s1;
8179             goto getlen;
8180         } else {
8181           warn_undef:
8182             if (ckWARN(WARN_UNINITIALIZED))
8183                 report_uninit((const SV *)sv);
8184             return 0;
8185         }
8186     }
8187   getlen:
8188     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8189         const char * const s = rx->subbeg - rx->suboffset + s1;
8190         const U8 *ep;
8191         STRLEN el;
8192
8193         i = t1 - s1;
8194         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8195                         i = el;
8196     }
8197     return i;
8198 }
8199
8200 SV*
8201 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8202 {
8203     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8204         PERL_UNUSED_ARG(rx);
8205         if (0)
8206             return NULL;
8207         else
8208             return newSVpvs("Regexp");
8209 }
8210
8211 /* Scans the name of a named buffer from the pattern.
8212  * If flags is REG_RSN_RETURN_NULL returns null.
8213  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8214  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8215  * to the parsed name as looked up in the RExC_paren_names hash.
8216  * If there is an error throws a vFAIL().. type exception.
8217  */
8218
8219 #define REG_RSN_RETURN_NULL    0
8220 #define REG_RSN_RETURN_NAME    1
8221 #define REG_RSN_RETURN_DATA    2
8222
8223 STATIC SV*
8224 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8225 {
8226     char *name_start = RExC_parse;
8227
8228     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8229
8230     assert (RExC_parse <= RExC_end);
8231     if (RExC_parse == RExC_end) NOOP;
8232     else if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
8233          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8234           * using do...while */
8235         if (UTF)
8236             do {
8237                 RExC_parse += UTF8SKIP(RExC_parse);
8238             } while (isWORDCHAR_utf8((U8*)RExC_parse));
8239         else
8240             do {
8241                 RExC_parse++;
8242             } while (isWORDCHAR(*RExC_parse));
8243     } else {
8244         RExC_parse++; /* so the <- from the vFAIL is after the offending
8245                          character */
8246         vFAIL("Group name must start with a non-digit word character");
8247     }
8248     if ( flags ) {
8249         SV* sv_name
8250             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8251                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8252         if ( flags == REG_RSN_RETURN_NAME)
8253             return sv_name;
8254         else if (flags==REG_RSN_RETURN_DATA) {
8255             HE *he_str = NULL;
8256             SV *sv_dat = NULL;
8257             if ( ! sv_name )      /* should not happen*/
8258                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8259             if (RExC_paren_names)
8260                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8261             if ( he_str )
8262                 sv_dat = HeVAL(he_str);
8263             if ( ! sv_dat )
8264                 vFAIL("Reference to nonexistent named group");
8265             return sv_dat;
8266         }
8267         else {
8268             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8269                        (unsigned long) flags);
8270         }
8271         NOT_REACHED; /* NOTREACHED */
8272     }
8273     return NULL;
8274 }
8275
8276 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8277     int num;                                                    \
8278     if (RExC_lastparse!=RExC_parse) {                           \
8279         Perl_re_printf( aTHX_  "%s",                                        \
8280             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8281                 RExC_end - RExC_parse, 16,                      \
8282                 "", "",                                         \
8283                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8284                 PERL_PV_PRETTY_ELLIPSES   |                     \
8285                 PERL_PV_PRETTY_LTGT       |                     \
8286                 PERL_PV_ESCAPE_RE         |                     \
8287                 PERL_PV_PRETTY_EXACTSIZE                        \
8288             )                                                   \
8289         );                                                      \
8290     } else                                                      \
8291         Perl_re_printf( aTHX_ "%16s","");                                   \
8292                                                                 \
8293     if (SIZE_ONLY)                                              \
8294        num = RExC_size + 1;                                     \
8295     else                                                        \
8296        num=REG_NODE_NUM(RExC_emit);                             \
8297     if (RExC_lastnum!=num)                                      \
8298        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8299     else                                                        \
8300        Perl_re_printf( aTHX_ "|%4s","");                                    \
8301     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8302         (int)((depth*2)), "",                                   \
8303         (funcname)                                              \
8304     );                                                          \
8305     RExC_lastnum=num;                                           \
8306     RExC_lastparse=RExC_parse;                                  \
8307 })
8308
8309
8310
8311 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8312     DEBUG_PARSE_MSG((funcname));                            \
8313     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8314 })
8315 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8316     DEBUG_PARSE_MSG((funcname));                            \
8317     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8318 })
8319
8320 /* This section of code defines the inversion list object and its methods.  The
8321  * interfaces are highly subject to change, so as much as possible is static to
8322  * this file.  An inversion list is here implemented as a malloc'd C UV array
8323  * as an SVt_INVLIST scalar.
8324  *
8325  * An inversion list for Unicode is an array of code points, sorted by ordinal
8326  * number.  The zeroth element is the first code point in the list.  The 1th
8327  * element is the first element beyond that not in the list.  In other words,
8328  * the first range is
8329  *  invlist[0]..(invlist[1]-1)
8330  * The other ranges follow.  Thus every element whose index is divisible by two
8331  * marks the beginning of a range that is in the list, and every element not
8332  * divisible by two marks the beginning of a range not in the list.  A single
8333  * element inversion list that contains the single code point N generally
8334  * consists of two elements
8335  *  invlist[0] == N
8336  *  invlist[1] == N+1
8337  * (The exception is when N is the highest representable value on the
8338  * machine, in which case the list containing just it would be a single
8339  * element, itself.  By extension, if the last range in the list extends to
8340  * infinity, then the first element of that range will be in the inversion list
8341  * at a position that is divisible by two, and is the final element in the
8342  * list.)
8343  * Taking the complement (inverting) an inversion list is quite simple, if the
8344  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8345  * This implementation reserves an element at the beginning of each inversion
8346  * list to always contain 0; there is an additional flag in the header which
8347  * indicates if the list begins at the 0, or is offset to begin at the next
8348  * element.
8349  *
8350  * More about inversion lists can be found in "Unicode Demystified"
8351  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8352  * More will be coming when functionality is added later.
8353  *
8354  * The inversion list data structure is currently implemented as an SV pointing
8355  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8356  * array of UV whose memory management is automatically handled by the existing
8357  * facilities for SV's.
8358  *
8359  * Some of the methods should always be private to the implementation, and some
8360  * should eventually be made public */
8361
8362 /* The header definitions are in F<invlist_inline.h> */
8363
8364 PERL_STATIC_INLINE UV*
8365 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8366 {
8367     /* Returns a pointer to the first element in the inversion list's array.
8368      * This is called upon initialization of an inversion list.  Where the
8369      * array begins depends on whether the list has the code point U+0000 in it
8370      * or not.  The other parameter tells it whether the code that follows this
8371      * call is about to put a 0 in the inversion list or not.  The first
8372      * element is either the element reserved for 0, if TRUE, or the element
8373      * after it, if FALSE */
8374
8375     bool* offset = get_invlist_offset_addr(invlist);
8376     UV* zero_addr = (UV *) SvPVX(invlist);
8377
8378     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8379
8380     /* Must be empty */
8381     assert(! _invlist_len(invlist));
8382
8383     *zero_addr = 0;
8384
8385     /* 1^1 = 0; 1^0 = 1 */
8386     *offset = 1 ^ will_have_0;
8387     return zero_addr + *offset;
8388 }
8389
8390 PERL_STATIC_INLINE void
8391 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8392 {
8393     /* Sets the current number of elements stored in the inversion list.
8394      * Updates SvCUR correspondingly */
8395     PERL_UNUSED_CONTEXT;
8396     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8397
8398     assert(SvTYPE(invlist) == SVt_INVLIST);
8399
8400     SvCUR_set(invlist,
8401               (len == 0)
8402                ? 0
8403                : TO_INTERNAL_SIZE(len + offset));
8404     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8405 }
8406
8407 #ifndef PERL_IN_XSUB_RE
8408
8409 STATIC void
8410 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8411 {
8412     /* Replaces the inversion list in 'src' with the one in 'dest'.  It steals
8413      * the list from 'src', so 'src' is made to have a NULL list.  This is
8414      * similar to what SvSetMagicSV() would do, if it were implemented on
8415      * inversion lists, though this routine avoids a copy */
8416
8417     const UV src_len          = _invlist_len(src);
8418     const bool src_offset     = *get_invlist_offset_addr(src);
8419     const STRLEN src_byte_len = SvLEN(src);
8420     char * array              = SvPVX(src);
8421
8422     const int oldtainted = TAINT_get;
8423
8424     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8425
8426     assert(SvTYPE(src) == SVt_INVLIST);
8427     assert(SvTYPE(dest) == SVt_INVLIST);
8428     assert(! invlist_is_iterating(src));
8429     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8430
8431     /* Make sure it ends in the right place with a NUL, as our inversion list
8432      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8433      * asserts it */
8434     array[src_byte_len - 1] = '\0';
8435
8436     TAINT_NOT;      /* Otherwise it breaks */
8437     sv_usepvn_flags(dest,
8438                     (char *) array,
8439                     src_byte_len - 1,
8440
8441                     /* This flag is documented to cause a copy to be avoided */
8442                     SV_HAS_TRAILING_NUL);
8443     TAINT_set(oldtainted);
8444     SvPV_set(src, 0);
8445     SvLEN_set(src, 0);
8446     SvCUR_set(src, 0);
8447
8448     /* Finish up copying over the other fields in an inversion list */
8449     *get_invlist_offset_addr(dest) = src_offset;
8450     invlist_set_len(dest, src_len, src_offset);
8451     *get_invlist_previous_index_addr(dest) = 0;
8452     invlist_iterfinish(dest);
8453 }
8454
8455 PERL_STATIC_INLINE IV*
8456 S_get_invlist_previous_index_addr(SV* invlist)
8457 {
8458     /* Return the address of the IV that is reserved to hold the cached index
8459      * */
8460     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8461
8462     assert(SvTYPE(invlist) == SVt_INVLIST);
8463
8464     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8465 }
8466
8467 PERL_STATIC_INLINE IV
8468 S_invlist_previous_index(SV* const invlist)
8469 {
8470     /* Returns cached index of previous search */
8471
8472     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8473
8474     return *get_invlist_previous_index_addr(invlist);
8475 }
8476
8477 PERL_STATIC_INLINE void
8478 S_invlist_set_previous_index(SV* const invlist, const IV index)
8479 {
8480     /* Caches <index> for later retrieval */
8481
8482     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8483
8484     assert(index == 0 || index < (int) _invlist_len(invlist));
8485
8486     *get_invlist_previous_index_addr(invlist) = index;
8487 }
8488
8489 PERL_STATIC_INLINE void
8490 S_invlist_trim(SV* invlist)
8491 {
8492     /* Free the not currently-being-used space in an inversion list */
8493
8494     /* But don't free up the space needed for the 0 UV that is always at the
8495      * beginning of the list, nor the trailing NUL */
8496     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8497
8498     PERL_ARGS_ASSERT_INVLIST_TRIM;
8499
8500     assert(SvTYPE(invlist) == SVt_INVLIST);
8501
8502     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8503 }
8504
8505 PERL_STATIC_INLINE void
8506 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8507 {
8508     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8509
8510     assert(SvTYPE(invlist) == SVt_INVLIST);
8511
8512     invlist_set_len(invlist, 0, 0);
8513     invlist_trim(invlist);
8514 }
8515
8516 #endif /* ifndef PERL_IN_XSUB_RE */
8517
8518 PERL_STATIC_INLINE bool
8519 S_invlist_is_iterating(SV* const invlist)
8520 {
8521     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8522
8523     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8524 }
8525
8526 PERL_STATIC_INLINE UV
8527 S_invlist_max(SV* const invlist)
8528 {
8529     /* Returns the maximum number of elements storable in the inversion list's
8530      * array, without having to realloc() */
8531
8532     PERL_ARGS_ASSERT_INVLIST_MAX;
8533
8534     assert(SvTYPE(invlist) == SVt_INVLIST);
8535
8536     /* Assumes worst case, in which the 0 element is not counted in the
8537      * inversion list, so subtracts 1 for that */
8538     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8539            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8540            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8541 }
8542
8543 #ifndef PERL_IN_XSUB_RE
8544 SV*
8545 Perl__new_invlist(pTHX_ IV initial_size)
8546 {
8547
8548     /* Return a pointer to a newly constructed inversion list, with enough
8549      * space to store 'initial_size' elements.  If that number is negative, a
8550      * system default is used instead */
8551
8552     SV* new_list;
8553
8554     if (initial_size < 0) {
8555         initial_size = 10;
8556     }
8557
8558     /* Allocate the initial space */
8559     new_list = newSV_type(SVt_INVLIST);
8560
8561     /* First 1 is in case the zero element isn't in the list; second 1 is for
8562      * trailing NUL */
8563     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8564     invlist_set_len(new_list, 0, 0);
8565
8566     /* Force iterinit() to be used to get iteration to work */
8567     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8568
8569     *get_invlist_previous_index_addr(new_list) = 0;
8570
8571     return new_list;
8572 }
8573
8574 SV*
8575 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8576 {
8577     /* Return a pointer to a newly constructed inversion list, initialized to
8578      * point to <list>, which has to be in the exact correct inversion list
8579      * form, including internal fields.  Thus this is a dangerous routine that
8580      * should not be used in the wrong hands.  The passed in 'list' contains
8581      * several header fields at the beginning that are not part of the
8582      * inversion list body proper */
8583
8584     const STRLEN length = (STRLEN) list[0];
8585     const UV version_id =          list[1];
8586     const bool offset   =    cBOOL(list[2]);
8587 #define HEADER_LENGTH 3
8588     /* If any of the above changes in any way, you must change HEADER_LENGTH
8589      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8590      *      perl -E 'say int(rand 2**31-1)'
8591      */
8592 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8593                                         data structure type, so that one being
8594                                         passed in can be validated to be an
8595                                         inversion list of the correct vintage.
8596                                        */
8597
8598     SV* invlist = newSV_type(SVt_INVLIST);
8599
8600     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8601
8602     if (version_id != INVLIST_VERSION_ID) {
8603         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8604     }
8605
8606     /* The generated array passed in includes header elements that aren't part
8607      * of the list proper, so start it just after them */
8608     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8609
8610     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8611                                shouldn't touch it */
8612
8613     *(get_invlist_offset_addr(invlist)) = offset;
8614
8615     /* The 'length' passed to us is the physical number of elements in the
8616      * inversion list.  But if there is an offset the logical number is one
8617      * less than that */
8618     invlist_set_len(invlist, length  - offset, offset);
8619
8620     invlist_set_previous_index(invlist, 0);
8621
8622     /* Initialize the iteration pointer. */
8623     invlist_iterfinish(invlist);
8624
8625     SvREADONLY_on(invlist);
8626
8627     return invlist;
8628 }
8629 #endif /* ifndef PERL_IN_XSUB_RE */
8630
8631 STATIC void
8632 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8633 {
8634     /* Grow the maximum size of an inversion list */
8635
8636     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8637
8638     assert(SvTYPE(invlist) == SVt_INVLIST);
8639
8640     /* Add one to account for the zero element at the beginning which may not
8641      * be counted by the calling parameters */
8642     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8643 }
8644
8645 STATIC void
8646 S__append_range_to_invlist(pTHX_ SV* const invlist,
8647                                  const UV start, const UV end)
8648 {
8649    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8650     * the end of the inversion list.  The range must be above any existing
8651     * ones. */
8652
8653     UV* array;
8654     UV max = invlist_max(invlist);
8655     UV len = _invlist_len(invlist);
8656     bool offset;
8657
8658     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8659
8660     if (len == 0) { /* Empty lists must be initialized */
8661         offset = start != 0;
8662         array = _invlist_array_init(invlist, ! offset);
8663     }
8664     else {
8665         /* Here, the existing list is non-empty. The current max entry in the
8666          * list is generally the first value not in the set, except when the
8667          * set extends to the end of permissible values, in which case it is
8668          * the first entry in that final set, and so this call is an attempt to
8669          * append out-of-order */
8670
8671         UV final_element = len - 1;
8672         array = invlist_array(invlist);
8673         if (array[final_element] > start
8674             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8675         {
8676             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",
8677                      array[final_element], start,
8678                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8679         }
8680
8681         /* Here, it is a legal append.  If the new range begins with the first
8682          * value not in the set, it is extending the set, so the new first
8683          * value not in the set is one greater than the newly extended range.
8684          * */
8685         offset = *get_invlist_offset_addr(invlist);
8686         if (array[final_element] == start) {
8687             if (end != UV_MAX) {
8688                 array[final_element] = end + 1;
8689             }
8690             else {
8691                 /* But if the end is the maximum representable on the machine,
8692                  * just let the range that this would extend to have no end */
8693                 invlist_set_len(invlist, len - 1, offset);
8694             }
8695             return;
8696         }
8697     }
8698
8699     /* Here the new range doesn't extend any existing set.  Add it */
8700
8701     len += 2;   /* Includes an element each for the start and end of range */
8702
8703     /* If wll overflow the existing space, extend, which may cause the array to
8704      * be moved */
8705     if (max < len) {
8706         invlist_extend(invlist, len);
8707
8708         /* Have to set len here to avoid assert failure in invlist_array() */
8709         invlist_set_len(invlist, len, offset);
8710
8711         array = invlist_array(invlist);
8712     }
8713     else {
8714         invlist_set_len(invlist, len, offset);
8715     }
8716
8717     /* The next item on the list starts the range, the one after that is
8718      * one past the new range.  */
8719     array[len - 2] = start;
8720     if (end != UV_MAX) {
8721         array[len - 1] = end + 1;
8722     }
8723     else {
8724         /* But if the end is the maximum representable on the machine, just let
8725          * the range have no end */
8726         invlist_set_len(invlist, len - 1, offset);
8727     }
8728 }
8729
8730 #ifndef PERL_IN_XSUB_RE
8731
8732 IV
8733 Perl__invlist_search(SV* const invlist, const UV cp)
8734 {
8735     /* Searches the inversion list for the entry that contains the input code
8736      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8737      * return value is the index into the list's array of the range that
8738      * contains <cp>, that is, 'i' such that
8739      *  array[i] <= cp < array[i+1]
8740      */
8741
8742     IV low = 0;
8743     IV mid;
8744     IV high = _invlist_len(invlist);
8745     const IV highest_element = high - 1;
8746     const UV* array;
8747
8748     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8749
8750     /* If list is empty, return failure. */
8751     if (high == 0) {
8752         return -1;
8753     }
8754
8755     /* (We can't get the array unless we know the list is non-empty) */
8756     array = invlist_array(invlist);
8757
8758     mid = invlist_previous_index(invlist);
8759     assert(mid >=0);
8760     if (mid > highest_element) {
8761         mid = highest_element;
8762     }
8763
8764     /* <mid> contains the cache of the result of the previous call to this
8765      * function (0 the first time).  See if this call is for the same result,
8766      * or if it is for mid-1.  This is under the theory that calls to this
8767      * function will often be for related code points that are near each other.
8768      * And benchmarks show that caching gives better results.  We also test
8769      * here if the code point is within the bounds of the list.  These tests
8770      * replace others that would have had to be made anyway to make sure that
8771      * the array bounds were not exceeded, and these give us extra information
8772      * at the same time */
8773     if (cp >= array[mid]) {
8774         if (cp >= array[highest_element]) {
8775             return highest_element;
8776         }
8777
8778         /* Here, array[mid] <= cp < array[highest_element].  This means that
8779          * the final element is not the answer, so can exclude it; it also
8780          * means that <mid> is not the final element, so can refer to 'mid + 1'
8781          * safely */
8782         if (cp < array[mid + 1]) {
8783             return mid;
8784         }
8785         high--;
8786         low = mid + 1;
8787     }
8788     else { /* cp < aray[mid] */
8789         if (cp < array[0]) { /* Fail if outside the array */
8790             return -1;
8791         }
8792         high = mid;
8793         if (cp >= array[mid - 1]) {
8794             goto found_entry;
8795         }
8796     }
8797
8798     /* Binary search.  What we are looking for is <i> such that
8799      *  array[i] <= cp < array[i+1]
8800      * The loop below converges on the i+1.  Note that there may not be an
8801      * (i+1)th element in the array, and things work nonetheless */
8802     while (low < high) {
8803         mid = (low + high) / 2;
8804         assert(mid <= highest_element);
8805         if (array[mid] <= cp) { /* cp >= array[mid] */
8806             low = mid + 1;
8807
8808             /* We could do this extra test to exit the loop early.
8809             if (cp < array[low]) {
8810                 return mid;
8811             }
8812             */
8813         }
8814         else { /* cp < array[mid] */
8815             high = mid;
8816         }
8817     }
8818
8819   found_entry:
8820     high--;
8821     invlist_set_previous_index(invlist, high);
8822     return high;
8823 }
8824
8825 void
8826 Perl__invlist_populate_swatch(SV* const invlist,
8827                               const UV start, const UV end, U8* swatch)
8828 {
8829     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8830      * but is used when the swash has an inversion list.  This makes this much
8831      * faster, as it uses a binary search instead of a linear one.  This is
8832      * intimately tied to that function, and perhaps should be in utf8.c,
8833      * except it is intimately tied to inversion lists as well.  It assumes
8834      * that <swatch> is all 0's on input */
8835
8836     UV current = start;
8837     const IV len = _invlist_len(invlist);
8838     IV i;
8839     const UV * array;
8840
8841     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8842
8843     if (len == 0) { /* Empty inversion list */
8844         return;
8845     }
8846
8847     array = invlist_array(invlist);
8848
8849     /* Find which element it is */
8850     i = _invlist_search(invlist, start);
8851
8852     /* We populate from <start> to <end> */
8853     while (current < end) {
8854         UV upper;
8855
8856         /* The inversion list gives the results for every possible code point
8857          * after the first one in the list.  Only those ranges whose index is
8858          * even are ones that the inversion list matches.  For the odd ones,
8859          * and if the initial code point is not in the list, we have to skip
8860          * forward to the next element */
8861         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8862             i++;
8863             if (i >= len) { /* Finished if beyond the end of the array */
8864                 return;
8865             }
8866             current = array[i];
8867             if (current >= end) {   /* Finished if beyond the end of what we
8868                                        are populating */
8869                 if (LIKELY(end < UV_MAX)) {
8870                     return;
8871                 }
8872
8873                 /* We get here when the upper bound is the maximum
8874                  * representable on the machine, and we are looking for just
8875                  * that code point.  Have to special case it */
8876                 i = len;
8877                 goto join_end_of_list;
8878             }
8879         }
8880         assert(current >= start);
8881
8882         /* The current range ends one below the next one, except don't go past
8883          * <end> */
8884         i++;
8885         upper = (i < len && array[i] < end) ? array[i] : end;
8886
8887         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8888          * for each code point in it */
8889         for (; current < upper; current++) {
8890             const STRLEN offset = (STRLEN)(current - start);
8891             swatch[offset >> 3] |= 1 << (offset & 7);
8892         }
8893
8894       join_end_of_list:
8895
8896         /* Quit if at the end of the list */
8897         if (i >= len) {
8898
8899             /* But first, have to deal with the highest possible code point on
8900              * the platform.  The previous code assumes that <end> is one
8901              * beyond where we want to populate, but that is impossible at the
8902              * platform's infinity, so have to handle it specially */
8903             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8904             {
8905                 const STRLEN offset = (STRLEN)(end - start);
8906                 swatch[offset >> 3] |= 1 << (offset & 7);
8907             }
8908             return;
8909         }
8910
8911         /* Advance to the next range, which will be for code points not in the
8912          * inversion list */
8913         current = array[i];
8914     }
8915
8916     return;
8917 }
8918
8919 void
8920 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8921                                          const bool complement_b, SV** output)
8922 {
8923     /* Take the union of two inversion lists and point <output> to it.  *output
8924      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8925      * the reference count to that list will be decremented if not already a
8926      * temporary (mortal); otherwise just its contents will be modified to be
8927      * the union.  The first list, <a>, may be NULL, in which case a copy of
8928      * the second list is returned.  If <complement_b> is TRUE, the union is
8929      * taken of the complement (inversion) of <b> instead of b itself.
8930      *
8931      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8932      * Richard Gillam, published by Addison-Wesley, and explained at some
8933      * length there.  The preface says to incorporate its examples into your
8934      * code at your own risk.
8935      *
8936      * The algorithm is like a merge sort.
8937      *
8938      * XXX A potential performance improvement is to keep track as we go along
8939      * if only one of the inputs contributes to the result, meaning the other
8940      * is a subset of that one.  In that case, we can skip the final copy and
8941      * return the larger of the input lists, but then outside code might need
8942      * to keep track of whether to free the input list or not */
8943
8944     const UV* array_a;    /* a's array */
8945     const UV* array_b;
8946     UV len_a;       /* length of a's array */
8947     UV len_b;
8948
8949     SV* u;                      /* the resulting union */
8950     UV* array_u;
8951     UV len_u = 0;
8952
8953     UV i_a = 0;             /* current index into a's array */
8954     UV i_b = 0;
8955     UV i_u = 0;
8956
8957     /* running count, as explained in the algorithm source book; items are
8958      * stopped accumulating and are output when the count changes to/from 0.
8959      * The count is incremented when we start a range that's in the set, and
8960      * decremented when we start a range that's not in the set.  So its range
8961      * is 0 to 2.  Only when the count is zero is something not in the set.
8962      */
8963     UV count = 0;
8964
8965     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
8966     assert(a != b);
8967
8968     len_b = _invlist_len(b);
8969     if (len_b == 0) {
8970
8971         /* Here, 'b' is empty.  If the output is the complement of 'b', the
8972          * union is all possible code points, and we need not even look at 'a'.
8973          * It's easiest to create a new inversion list that matches everything.
8974          * */
8975         if (complement_b) {
8976             SV* everything = _new_invlist(1);
8977             _append_range_to_invlist(everything, 0, UV_MAX);
8978
8979             /* If the output didn't exist, just point it at the new list */
8980             if (*output == NULL) {
8981                 *output = everything;
8982                 return;
8983             }
8984
8985             /* Otherwise, replace its contents with the new list */
8986             invlist_replace_list_destroys_src(*output, everything);
8987             SvREFCNT_dec_NN(everything);
8988             return;
8989         }
8990
8991         /* Here, we don't want the complement of 'b', and since it is empty,
8992          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
8993          * output will be empty */
8994
8995         if (a == NULL) {
8996             *output = _new_invlist(0);
8997             return;
8998         }
8999
9000         if (_invlist_len(a) == 0) {
9001             invlist_clear(*output);
9002             return;
9003         }
9004
9005         /* Here, 'a' is not empty, and entirely determines the union.  If the
9006          * output is not to overwrite 'b', we can just return 'a'. */
9007         if (*output != b) {
9008
9009             /* If the output is to overwrite 'a', we have a no-op, as it's
9010              * already in 'a' */
9011             if (*output == a) {
9012                 return;
9013             }
9014
9015             /* But otherwise we have to copy 'a' to the output */
9016             *output = invlist_clone(a);
9017             return;
9018         }
9019
9020         /* Here, 'b' is to be overwritten by the output, which will be 'a' */
9021         u = invlist_clone(a);
9022         invlist_replace_list_destroys_src(*output, u);
9023         SvREFCNT_dec_NN(u);
9024
9025         return;
9026     }
9027
9028     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9029
9030         /* Here, 'a' is empty (and b is not).  That means the union will come
9031          * entirely from 'b'.  If the output is not to overwrite 'a', we can
9032          * just return what's in 'b'.  */
9033         if (*output != a) {
9034
9035             /* If the output is to overwrite 'b', it's already in 'b', but
9036              * otherwise we have to copy 'b' to the output */
9037             if (*output != b) {
9038                 *output = invlist_clone(b);
9039             }
9040
9041             /* And if the output is to be the inversion of 'b', do that */
9042             if (complement_b) {
9043                 _invlist_invert(*output);
9044             }
9045
9046             return;
9047         }
9048
9049         /* Here, 'a', which is empty or even NULL, is to be overwritten by the
9050          * output, which will either be 'b' or the complement of 'b' */
9051
9052         if (a == NULL) {
9053             *output = invlist_clone(b);
9054         }
9055         else {
9056             u = invlist_clone(b);
9057             invlist_replace_list_destroys_src(*output, u);
9058             SvREFCNT_dec_NN(u);
9059         }
9060
9061         if (complement_b) {
9062             _invlist_invert(*output);
9063         }
9064
9065         return;
9066     }
9067
9068     /* Here both lists exist and are non-empty */
9069     array_a = invlist_array(a);
9070     array_b = invlist_array(b);
9071
9072     /* If are to take the union of 'a' with the complement of b, set it
9073      * up so are looking at b's complement. */
9074     if (complement_b) {
9075
9076         /* To complement, we invert: if the first element is 0, remove it.  To
9077          * do this, we just pretend the array starts one later */
9078         if (array_b[0] == 0) {
9079             array_b++;
9080             len_b--;
9081         }
9082         else {
9083
9084             /* But if the first element is not zero, we pretend the list starts
9085              * at the 0 that is always stored immediately before the array. */
9086             array_b--;
9087             len_b++;
9088         }
9089     }
9090
9091     /* Size the union for the worst case: that the sets are completely
9092      * disjoint */
9093     u = _new_invlist(len_a + len_b);
9094
9095     /* Will contain U+0000 if either component does */
9096     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
9097                                       || (len_b > 0 && array_b[0] == 0));
9098
9099     /* Go through each list item by item, stopping when exhausted one of
9100      * them */
9101     while (i_a < len_a && i_b < len_b) {
9102         UV cp;      /* The element to potentially add to the union's array */
9103         bool cp_in_set;   /* is it in the the input list's set or not */
9104
9105         /* We need to take one or the other of the two inputs for the union.
9106          * Since we are merging two sorted lists, we take the smaller of the
9107          * next items.  In case of a tie, we take the one that is in its set
9108          * first.  If we took one not in the set first, it would decrement the
9109          * count, possibly to 0 which would cause it to be output as ending the
9110          * range, and the next time through we would take the same number, and
9111          * output it again as beginning the next range.  By doing it the
9112          * opposite way, there is no possibility that the count will be
9113          * momentarily decremented to 0, and thus the two adjoining ranges will
9114          * be seamlessly merged.  (In a tie and both are in the set or both not
9115          * in the set, it doesn't matter which we take first.) */
9116         if (array_a[i_a] < array_b[i_b]
9117             || (array_a[i_a] == array_b[i_b]
9118                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9119         {
9120             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9121             cp= array_a[i_a++];
9122         }
9123         else {
9124             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9125             cp = array_b[i_b++];
9126         }
9127
9128         /* Here, have chosen which of the two inputs to look at.  Only output
9129          * if the running count changes to/from 0, which marks the
9130          * beginning/end of a range that's in the set */
9131         if (cp_in_set) {
9132             if (count == 0) {
9133                 array_u[i_u++] = cp;
9134             }
9135             count++;
9136         }
9137         else {
9138             count--;
9139             if (count == 0) {
9140                 array_u[i_u++] = cp;
9141             }
9142         }
9143     }
9144
9145     /* Here, we are finished going through at least one of the lists, which
9146      * means there is something remaining in at most one.  We check if the list
9147      * that hasn't been exhausted is positioned such that we are in the middle
9148      * of a range in its set or not.  (i_a and i_b point to the element beyond
9149      * the one we care about.) If in the set, we decrement 'count'; if 0, there
9150      * is potentially more to output.
9151      * There are four cases:
9152      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
9153      *     in the union is entirely from the non-exhausted set.
9154      *  2) Both were in their sets, count is 2.  Nothing further should
9155      *     be output, as everything that remains will be in the exhausted
9156      *     list's set, hence in the union; decrementing to 1 but not 0 insures
9157      *     that
9158      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
9159      *     Nothing further should be output because the union includes
9160      *     everything from the exhausted set.  Not decrementing ensures that.
9161      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
9162      *     decrementing to 0 insures that we look at the remainder of the
9163      *     non-exhausted set */
9164     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9165         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9166     {
9167         count--;
9168     }
9169
9170     /* The final length is what we've output so far, plus what else is about to
9171      * be output.  (If 'count' is non-zero, then the input list we exhausted
9172      * has everything remaining up to the machine's limit in its set, and hence
9173      * in the union, so there will be no further output. */
9174     len_u = i_u;
9175     if (count == 0) {
9176         /* At most one of the subexpressions will be non-zero */
9177         len_u += (len_a - i_a) + (len_b - i_b);
9178     }
9179
9180     /* Set the result to the final length, which can change the pointer to
9181      * array_u, so re-find it.  (Note that it is unlikely that this will
9182      * change, as we are shrinking the space, not enlarging it) */
9183     if (len_u != _invlist_len(u)) {
9184         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9185         invlist_trim(u);
9186         array_u = invlist_array(u);
9187     }
9188
9189     /* When 'count' is 0, the list that was exhausted (if one was shorter than
9190      * the other) ended with everything above it not in its set.  That means
9191      * that the remaining part of the union is precisely the same as the
9192      * non-exhausted list, so can just copy it unchanged.  (If both lists were
9193      * exhausted at the same time, then the operations below will be both 0.)
9194      */
9195     if (count == 0) {
9196         IV copy_count; /* At most one will have a non-zero copy count */
9197         if ((copy_count = len_a - i_a) > 0) {
9198             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9199         }
9200         else if ((copy_count = len_b - i_b) > 0) {
9201             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9202         }
9203     }
9204
9205     /* If the output is not to overwrite either of the inputs, just return the
9206      * calculated union */
9207     if (a != *output && b != *output) {
9208         *output = u;
9209     }
9210     else {
9211         /*  Here, the output is to be the same as one of the input scalars,
9212          *  hence replacing it.  The simple thing to do is to free the input
9213          *  scalar, making it instead be the output one.  But experience has
9214          *  shown [perl #127392] that if the input is a mortal, we can get a
9215          *  huge build-up of these during regex compilation before they get
9216          *  freed.  So for that case, replace just the input's interior with
9217          *  the output's, and then free the output */
9218
9219         assert(! invlist_is_iterating(*output));
9220
9221         if (! SvTEMP(*output)) {
9222             SvREFCNT_dec_NN(*output);
9223             *output = u;
9224         }
9225         else {
9226             invlist_replace_list_destroys_src(*output, u);
9227             SvREFCNT_dec_NN(u);
9228         }
9229     }
9230
9231     return;
9232 }
9233
9234 void
9235 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9236                                                const bool complement_b, SV** i)
9237 {
9238     /* Take the intersection of two inversion lists and point <i> to it.  *i
9239      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
9240      * the reference count to that list will be decremented if not already a
9241      * temporary (mortal); otherwise just its contents will be modified to be
9242      * the intersection.  The first list, <a>, may be NULL, in which case an
9243      * empty list is returned.  If <complement_b> is TRUE, the result will be
9244      * the intersection of <a> and the complement (or inversion) of <b> instead
9245      * of <b> directly.
9246      *
9247      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9248      * Richard Gillam, published by Addison-Wesley, and explained at some
9249      * length there.  The preface says to incorporate its examples into your
9250      * code at your own risk.  In fact, it had bugs
9251      *
9252      * The algorithm is like a merge sort, and is essentially the same as the
9253      * union above
9254      */
9255
9256     const UV* array_a;          /* a's array */
9257     const UV* array_b;
9258     UV len_a;   /* length of a's array */
9259     UV len_b;
9260
9261     SV* r;                   /* the resulting intersection */
9262     UV* array_r;
9263     UV len_r = 0;
9264
9265     UV i_a = 0;             /* current index into a's array */
9266     UV i_b = 0;
9267     UV i_r = 0;
9268
9269     /* running count, as explained in the algorithm source book; items are
9270      * stopped accumulating and are output when the count changes to/from 2.
9271      * The count is incremented when we start a range that's in the set, and
9272      * decremented when we start a range that's not in the set.  So its range
9273      * is 0 to 2.  Only when the count is 2 is something in the intersection.
9274      */
9275     UV count = 0;
9276
9277     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9278     assert(a != b);
9279
9280     /* Special case if either one is empty */
9281     len_a = (a == NULL) ? 0 : _invlist_len(a);
9282     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9283         if (len_a != 0 && complement_b) {
9284
9285             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9286              * must be empty.  Here, also we are using 'b's complement, which
9287              * hence must be every possible code point.  Thus the intersection
9288              * is simply 'a'. */
9289
9290             if (*i == a) {  /* No-op */
9291                 return;
9292             }
9293
9294             /* If not overwriting either input, just make a copy of 'a' */
9295             if (*i != b) {
9296                 *i = invlist_clone(a);
9297                 return;
9298             }
9299
9300             /* Here we are overwriting 'b' with 'a's contents */
9301             r = invlist_clone(a);
9302             invlist_replace_list_destroys_src(*i, r);
9303             SvREFCNT_dec_NN(r);
9304             return;
9305         }
9306
9307         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9308          * intersection must be empty */
9309         if (*i == NULL) {
9310             *i = _new_invlist(0);
9311             return;
9312         }
9313
9314         invlist_clear(*i);
9315         return;
9316     }
9317
9318     /* Here both lists exist and are non-empty */
9319     array_a = invlist_array(a);
9320     array_b = invlist_array(b);
9321
9322     /* If are to take the intersection of 'a' with the complement of b, set it
9323      * up so are looking at b's complement. */
9324     if (complement_b) {
9325
9326         /* To complement, we invert: if the first element is 0, remove it.  To
9327          * do this, we just pretend the array starts one later */
9328         if (array_b[0] == 0) {
9329             array_b++;
9330             len_b--;
9331         }
9332         else {
9333
9334             /* But if the first element is not zero, we pretend the list starts
9335              * at the 0 that is always stored immediately before the array. */
9336             array_b--;
9337             len_b++;
9338         }
9339     }
9340
9341     /* Size the intersection for the worst case: that the intersection ends up
9342      * fragmenting everything to be completely disjoint */
9343     r= _new_invlist(len_a + len_b);
9344
9345     /* Will contain U+0000 iff both components do */
9346     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
9347                                      && len_b > 0 && array_b[0] == 0);
9348
9349     /* Go through each list item by item, stopping when exhausted one of
9350      * them */
9351     while (i_a < len_a && i_b < len_b) {
9352         UV cp;      /* The element to potentially add to the intersection's
9353                        array */
9354         bool cp_in_set; /* Is it in the input list's set or not */
9355
9356         /* We need to take one or the other of the two inputs for the
9357          * intersection.  Since we are merging two sorted lists, we take the
9358          * smaller of the next items.  In case of a tie, we take the one that
9359          * is not in its set first (a difference from the union algorithm).  If
9360          * we took one in the set first, it would increment the count, possibly
9361          * to 2 which would cause it to be output as starting a range in the
9362          * intersection, and the next time through we would take that same
9363          * number, and output it again as ending the set.  By doing it the
9364          * opposite of this, there is no possibility that the count will be
9365          * momentarily incremented to 2.  (In a tie and both are in the set or
9366          * both not in the set, it doesn't matter which we take first.) */
9367         if (array_a[i_a] < array_b[i_b]
9368             || (array_a[i_a] == array_b[i_b]
9369                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9370         {
9371             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9372             cp= array_a[i_a++];
9373         }
9374         else {
9375             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9376             cp= array_b[i_b++];
9377         }
9378
9379         /* Here, have chosen which of the two inputs to look at.  Only output
9380          * if the running count changes to/from 2, which marks the
9381          * beginning/end of a range that's in the intersection */
9382         if (cp_in_set) {
9383             count++;
9384             if (count == 2) {
9385                 array_r[i_r++] = cp;
9386             }
9387         }
9388         else {
9389             if (count == 2) {
9390                 array_r[i_r++] = cp;
9391             }
9392             count--;
9393         }
9394     }
9395
9396     /* Here, we are finished going through at least one of the lists, which
9397      * means there is something remaining in at most one.  We check if the list
9398      * that has been exhausted is positioned such that we are in the middle
9399      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
9400      * the ones we care about.)  There are four cases:
9401      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
9402      *     nothing left in the intersection.
9403      *  2) Both were in their sets, count is 2 and perhaps is incremented to
9404      *     above 2.  What should be output is exactly that which is in the
9405      *     non-exhausted set, as everything it has is also in the intersection
9406      *     set, and everything it doesn't have can't be in the intersection
9407      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
9408      *     gets incremented to 2.  Like the previous case, the intersection is
9409      *     everything that remains in the non-exhausted set.
9410      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
9411      *     remains 1.  And the intersection has nothing more. */
9412     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9413         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9414     {
9415         count++;
9416     }
9417
9418     /* The final length is what we've output so far plus what else is in the
9419      * intersection.  At most one of the subexpressions below will be non-zero
9420      * */
9421     len_r = i_r;
9422     if (count >= 2) {
9423         len_r += (len_a - i_a) + (len_b - i_b);
9424     }
9425
9426     /* Set the result to the final length, which can change the pointer to
9427      * array_r, so re-find it.  (Note that it is unlikely that this will
9428      * change, as we are shrinking the space, not enlarging it) */
9429     if (len_r != _invlist_len(r)) {
9430         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9431         invlist_trim(r);
9432         array_r = invlist_array(r);
9433     }
9434
9435     /* Finish outputting any remaining */
9436     if (count >= 2) { /* At most one will have a non-zero copy count */
9437         IV copy_count;
9438         if ((copy_count = len_a - i_a) > 0) {
9439             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9440         }
9441         else if ((copy_count = len_b - i_b) > 0) {
9442             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9443         }
9444     }
9445
9446     /* If the output is not to overwrite either of the inputs, just return the
9447      * calculated intersection */
9448     if (a != *i && b != *i) {
9449         *i = r;
9450     }
9451     else {
9452         /*  Here, the output is to be the same as one of the input scalars,
9453          *  hence replacing it.  The simple thing to do is to free the input
9454          *  scalar, making it instead be the output one.  But experience has
9455          *  shown [perl #127392] that if the input is a mortal, we can get a
9456          *  huge build-up of these during regex compilation before they get
9457          *  freed.  So for that case, replace just the input's interior with
9458          *  the output's, and then free the output.  A short-cut in this case
9459          *  is if the output is empty, we can just set the input to be empty */
9460
9461         assert(! invlist_is_iterating(*i));
9462
9463         if (! SvTEMP(*i)) {
9464             SvREFCNT_dec_NN(*i);
9465             *i = r;
9466         }
9467         else {
9468             if (len_r) {
9469                 invlist_replace_list_destroys_src(*i, r);
9470             }
9471             else {
9472                 invlist_clear(*i);
9473             }
9474             SvREFCNT_dec_NN(r);
9475         }
9476     }
9477
9478     return;
9479 }
9480
9481 SV*
9482 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
9483 {
9484     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9485      * set.  A pointer to the inversion list is returned.  This may actually be
9486      * a new list, in which case the passed in one has been destroyed.  The
9487      * passed-in inversion list can be NULL, in which case a new one is created
9488      * with just the one range in it */
9489
9490     SV* range_invlist;
9491     UV len;
9492
9493     if (invlist == NULL) {
9494         invlist = _new_invlist(2);
9495         len = 0;
9496     }
9497     else {
9498         len = _invlist_len(invlist);
9499     }
9500
9501     /* If comes after the final entry actually in the list, can just append it
9502      * to the end, */
9503     if (len == 0
9504         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
9505             && start >= invlist_array(invlist)[len - 1]))
9506     {
9507         _append_range_to_invlist(invlist, start, end);
9508         return invlist;
9509     }
9510
9511     /* Here, can't just append things, create and return a new inversion list
9512      * which is the union of this range and the existing inversion list.  (If
9513      * the new range is well-behaved wrt to the old one, we could just insert
9514      * it, doing a Move() down on the tail of the old one (potentially growing
9515      * it first).  But to determine that means we would have the extra
9516      * (possibly throw-away) work of first finding where the new one goes and
9517      * whether it disrupts (splits) an existing range, so it doesn't appear to
9518      * me (khw) that it's worth it) */
9519     range_invlist = _new_invlist(2);
9520     _append_range_to_invlist(range_invlist, start, end);
9521
9522     _invlist_union(invlist, range_invlist, &invlist);
9523
9524     /* The temporary can be freed */
9525     SvREFCNT_dec_NN(range_invlist);
9526
9527     return invlist;
9528 }
9529
9530 SV*
9531 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9532                                  UV** other_elements_ptr)
9533 {
9534     /* Create and return an inversion list whose contents are to be populated
9535      * by the caller.  The caller gives the number of elements (in 'size') and
9536      * the very first element ('element0').  This function will set
9537      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9538      * are to be placed.
9539      *
9540      * Obviously there is some trust involved that the caller will properly
9541      * fill in the other elements of the array.
9542      *
9543      * (The first element needs to be passed in, as the underlying code does
9544      * things differently depending on whether it is zero or non-zero) */
9545
9546     SV* invlist = _new_invlist(size);
9547     bool offset;
9548
9549     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9550
9551     _append_range_to_invlist(invlist, element0, element0);
9552     offset = *get_invlist_offset_addr(invlist);
9553
9554     invlist_set_len(invlist, size, offset);
9555     *other_elements_ptr = invlist_array(invlist) + 1;
9556     return invlist;
9557 }
9558
9559 #endif
9560
9561 PERL_STATIC_INLINE SV*
9562 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9563     return _add_range_to_invlist(invlist, cp, cp);
9564 }
9565
9566 #ifndef PERL_IN_XSUB_RE
9567 void
9568 Perl__invlist_invert(pTHX_ SV* const invlist)
9569 {
9570     /* Complement the input inversion list.  This adds a 0 if the list didn't
9571      * have a zero; removes it otherwise.  As described above, the data
9572      * structure is set up so that this is very efficient */
9573
9574     PERL_ARGS_ASSERT__INVLIST_INVERT;
9575
9576     assert(! invlist_is_iterating(invlist));
9577
9578     /* The inverse of matching nothing is matching everything */
9579     if (_invlist_len(invlist) == 0) {
9580         _append_range_to_invlist(invlist, 0, UV_MAX);
9581         return;
9582     }
9583
9584     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9585 }
9586
9587 #endif
9588
9589 PERL_STATIC_INLINE SV*
9590 S_invlist_clone(pTHX_ SV* const invlist)
9591 {
9592
9593     /* Return a new inversion list that is a copy of the input one, which is
9594      * unchanged.  The new list will not be mortal even if the old one was. */
9595
9596     /* Need to allocate extra space to accommodate Perl's addition of a
9597      * trailing NUL to SvPV's, since it thinks they are always strings */
9598     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9599     STRLEN physical_length = SvCUR(invlist);
9600     bool offset = *(get_invlist_offset_addr(invlist));
9601
9602     PERL_ARGS_ASSERT_INVLIST_CLONE;
9603
9604     *(get_invlist_offset_addr(new_invlist)) = offset;
9605     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9606     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9607
9608     return new_invlist;
9609 }
9610
9611 PERL_STATIC_INLINE STRLEN*
9612 S_get_invlist_iter_addr(SV* invlist)
9613 {
9614     /* Return the address of the UV that contains the current iteration
9615      * position */
9616
9617     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9618
9619     assert(SvTYPE(invlist) == SVt_INVLIST);
9620
9621     return &(((XINVLIST*) SvANY(invlist))->iterator);
9622 }
9623
9624 PERL_STATIC_INLINE void
9625 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9626 {
9627     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9628
9629     *get_invlist_iter_addr(invlist) = 0;
9630 }
9631
9632 PERL_STATIC_INLINE void
9633 S_invlist_iterfinish(SV* invlist)
9634 {
9635     /* Terminate iterator for invlist.  This is to catch development errors.
9636      * Any iteration that is interrupted before completed should call this
9637      * function.  Functions that add code points anywhere else but to the end
9638      * of an inversion list assert that they are not in the middle of an
9639      * iteration.  If they were, the addition would make the iteration
9640      * problematical: if the iteration hadn't reached the place where things
9641      * were being added, it would be ok */
9642
9643     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9644
9645     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9646 }
9647
9648 STATIC bool
9649 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9650 {
9651     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9652      * This call sets in <*start> and <*end>, the next range in <invlist>.
9653      * Returns <TRUE> if successful and the next call will return the next
9654      * range; <FALSE> if was already at the end of the list.  If the latter,
9655      * <*start> and <*end> are unchanged, and the next call to this function
9656      * will start over at the beginning of the list */
9657
9658     STRLEN* pos = get_invlist_iter_addr(invlist);
9659     UV len = _invlist_len(invlist);
9660     UV *array;
9661
9662     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9663
9664     if (*pos >= len) {
9665         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9666         return FALSE;
9667     }
9668
9669     array = invlist_array(invlist);
9670
9671     *start = array[(*pos)++];
9672
9673     if (*pos >= len) {
9674         *end = UV_MAX;
9675     }
9676     else {
9677         *end = array[(*pos)++] - 1;
9678     }
9679
9680     return TRUE;
9681 }
9682
9683 PERL_STATIC_INLINE UV
9684 S_invlist_highest(SV* const invlist)
9685 {
9686     /* Returns the highest code point that matches an inversion list.  This API
9687      * has an ambiguity, as it returns 0 under either the highest is actually
9688      * 0, or if the list is empty.  If this distinction matters to you, check
9689      * for emptiness before calling this function */
9690
9691     UV len = _invlist_len(invlist);
9692     UV *array;
9693
9694     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9695
9696     if (len == 0) {
9697         return 0;
9698     }
9699
9700     array = invlist_array(invlist);
9701
9702     /* The last element in the array in the inversion list always starts a
9703      * range that goes to infinity.  That range may be for code points that are
9704      * matched in the inversion list, or it may be for ones that aren't
9705      * matched.  In the latter case, the highest code point in the set is one
9706      * less than the beginning of this range; otherwise it is the final element
9707      * of this range: infinity */
9708     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9709            ? UV_MAX
9710            : array[len - 1] - 1;
9711 }
9712
9713 STATIC SV *
9714 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
9715 {
9716     /* Get the contents of an inversion list into a string SV so that they can
9717      * be printed out.  If 'traditional_style' is TRUE, it uses the format
9718      * traditionally done for debug tracing; otherwise it uses a format
9719      * suitable for just copying to the output, with blanks between ranges and
9720      * a dash between range components */
9721
9722     UV start, end;
9723     SV* output;
9724     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
9725     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
9726
9727     if (traditional_style) {
9728         output = newSVpvs("\n");
9729     }
9730     else {
9731         output = newSVpvs("");
9732     }
9733
9734     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
9735
9736     assert(! invlist_is_iterating(invlist));
9737
9738     invlist_iterinit(invlist);
9739     while (invlist_iternext(invlist, &start, &end)) {
9740         if (end == UV_MAX) {
9741             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"%cINFINITY%c",
9742                                           start, intra_range_delimiter,
9743                                                  inter_range_delimiter);
9744         }
9745         else if (end != start) {
9746             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"%c%04"UVXf"%c",
9747                                           start,
9748                                                    intra_range_delimiter,
9749                                                   end, inter_range_delimiter);
9750         }
9751         else {
9752             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"%c",
9753                                           start, inter_range_delimiter);
9754         }
9755     }
9756
9757     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
9758         SvCUR_set(output, SvCUR(output) - 1);
9759     }
9760
9761     return output;
9762 }
9763
9764 #ifndef PERL_IN_XSUB_RE
9765 void
9766 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
9767                          const char * const indent, SV* const invlist)
9768 {
9769     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
9770      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
9771      * the string 'indent'.  The output looks like this:
9772          [0] 0x000A .. 0x000D
9773          [2] 0x0085
9774          [4] 0x2028 .. 0x2029
9775          [6] 0x3104 .. INFINITY
9776      * This means that the first range of code points matched by the list are
9777      * 0xA through 0xD; the second range contains only the single code point
9778      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
9779      * are used to define each range (except if the final range extends to
9780      * infinity, only a single element is needed).  The array index of the
9781      * first element for the corresponding range is given in brackets. */
9782
9783     UV start, end;
9784     STRLEN count = 0;
9785
9786     PERL_ARGS_ASSERT__INVLIST_DUMP;
9787
9788     if (invlist_is_iterating(invlist)) {
9789         Perl_dump_indent(aTHX_ level, file,
9790              "%sCan't dump inversion list because is in middle of iterating\n",
9791              indent);
9792         return;
9793     }
9794
9795     invlist_iterinit(invlist);
9796     while (invlist_iternext(invlist, &start, &end)) {
9797         if (end == UV_MAX) {
9798             Perl_dump_indent(aTHX_ level, file,
9799                                        "%s[%"UVuf"] 0x%04"UVXf" .. INFINITY\n",
9800                                    indent, (UV)count, start);
9801         }
9802         else if (end != start) {
9803             Perl_dump_indent(aTHX_ level, file,
9804                                     "%s[%"UVuf"] 0x%04"UVXf" .. 0x%04"UVXf"\n",
9805                                 indent, (UV)count, start,         end);
9806         }
9807         else {
9808             Perl_dump_indent(aTHX_ level, file, "%s[%"UVuf"] 0x%04"UVXf"\n",
9809                                             indent, (UV)count, start);
9810         }
9811         count += 2;
9812     }
9813 }
9814
9815 void
9816 Perl__load_PL_utf8_foldclosures (pTHX)
9817 {
9818     assert(! PL_utf8_foldclosures);
9819
9820     /* If the folds haven't been read in, call a fold function
9821      * to force that */
9822     if (! PL_utf8_tofold) {
9823         U8 dummy[UTF8_MAXBYTES_CASE+1];
9824
9825         /* This string is just a short named one above \xff */
9826         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
9827         assert(PL_utf8_tofold); /* Verify that worked */
9828     }
9829     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
9830 }
9831 #endif
9832
9833 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
9834 bool
9835 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
9836 {
9837     /* Return a boolean as to if the two passed in inversion lists are
9838      * identical.  The final argument, if TRUE, says to take the complement of
9839      * the second inversion list before doing the comparison */
9840
9841     const UV* array_a = invlist_array(a);
9842     const UV* array_b = invlist_array(b);
9843     UV len_a = _invlist_len(a);
9844     UV len_b = _invlist_len(b);
9845
9846     UV i = 0;               /* current index into the arrays */
9847     bool retval = TRUE;     /* Assume are identical until proven otherwise */
9848
9849     PERL_ARGS_ASSERT__INVLISTEQ;
9850
9851     /* If are to compare 'a' with the complement of b, set it
9852      * up so are looking at b's complement. */
9853     if (complement_b) {
9854
9855         /* The complement of nothing is everything, so <a> would have to have
9856          * just one element, starting at zero (ending at infinity) */
9857         if (len_b == 0) {
9858             return (len_a == 1 && array_a[0] == 0);
9859         }
9860         else if (array_b[0] == 0) {
9861
9862             /* Otherwise, to complement, we invert.  Here, the first element is
9863              * 0, just remove it.  To do this, we just pretend the array starts
9864              * one later */
9865
9866             array_b++;
9867             len_b--;
9868         }
9869         else {
9870
9871             /* But if the first element is not zero, we pretend the list starts
9872              * at the 0 that is always stored immediately before the array. */
9873             array_b--;
9874             len_b++;
9875         }
9876     }
9877
9878     /* Make sure that the lengths are the same, as well as the final element
9879      * before looping through the remainder.  (Thus we test the length, final,
9880      * and first elements right off the bat) */
9881     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
9882         retval = FALSE;
9883     }
9884     else for (i = 0; i < len_a - 1; i++) {
9885         if (array_a[i] != array_b[i]) {
9886             retval = FALSE;
9887             break;
9888         }
9889     }
9890
9891     return retval;
9892 }
9893 #endif
9894
9895 /*
9896  * As best we can, determine the characters that can match the start of
9897  * the given EXACTF-ish node.
9898  *
9899  * Returns the invlist as a new SV*; it is the caller's responsibility to
9900  * call SvREFCNT_dec() when done with it.
9901  */
9902 STATIC SV*
9903 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
9904 {
9905     const U8 * s = (U8*)STRING(node);
9906     SSize_t bytelen = STR_LEN(node);
9907     UV uc;
9908     /* Start out big enough for 2 separate code points */
9909     SV* invlist = _new_invlist(4);
9910
9911     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
9912
9913     if (! UTF) {
9914         uc = *s;
9915
9916         /* We punt and assume can match anything if the node begins
9917          * with a multi-character fold.  Things are complicated.  For
9918          * example, /ffi/i could match any of:
9919          *  "\N{LATIN SMALL LIGATURE FFI}"
9920          *  "\N{LATIN SMALL LIGATURE FF}I"
9921          *  "F\N{LATIN SMALL LIGATURE FI}"
9922          *  plus several other things; and making sure we have all the
9923          *  possibilities is hard. */
9924         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
9925             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
9926         }
9927         else {
9928             /* Any Latin1 range character can potentially match any
9929              * other depending on the locale */
9930             if (OP(node) == EXACTFL) {
9931                 _invlist_union(invlist, PL_Latin1, &invlist);
9932             }
9933             else {
9934                 /* But otherwise, it matches at least itself.  We can
9935                  * quickly tell if it has a distinct fold, and if so,
9936                  * it matches that as well */
9937                 invlist = add_cp_to_invlist(invlist, uc);
9938                 if (IS_IN_SOME_FOLD_L1(uc))
9939                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
9940             }
9941
9942             /* Some characters match above-Latin1 ones under /i.  This
9943              * is true of EXACTFL ones when the locale is UTF-8 */
9944             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
9945                 && (! isASCII(uc) || (OP(node) != EXACTFA
9946                                     && OP(node) != EXACTFA_NO_TRIE)))
9947             {
9948                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
9949             }
9950         }
9951     }
9952     else {  /* Pattern is UTF-8 */
9953         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
9954         STRLEN foldlen = UTF8SKIP(s);
9955         const U8* e = s + bytelen;
9956         SV** listp;
9957
9958         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
9959
9960         /* The only code points that aren't folded in a UTF EXACTFish
9961          * node are are the problematic ones in EXACTFL nodes */
9962         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
9963             /* We need to check for the possibility that this EXACTFL
9964              * node begins with a multi-char fold.  Therefore we fold
9965              * the first few characters of it so that we can make that
9966              * check */
9967             U8 *d = folded;
9968             int i;
9969
9970             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
9971                 if (isASCII(*s)) {
9972                     *(d++) = (U8) toFOLD(*s);
9973                     s++;
9974                 }
9975                 else {
9976                     STRLEN len;
9977                     to_utf8_fold(s, d, &len);
9978                     d += len;
9979                     s += UTF8SKIP(s);
9980                 }
9981             }
9982
9983             /* And set up so the code below that looks in this folded
9984              * buffer instead of the node's string */
9985             e = d;
9986             foldlen = UTF8SKIP(folded);
9987             s = folded;
9988         }
9989
9990         /* When we reach here 's' points to the fold of the first
9991          * character(s) of the node; and 'e' points to far enough along
9992          * the folded string to be just past any possible multi-char
9993          * fold. 'foldlen' is the length in bytes of the first
9994          * character in 's'
9995          *
9996          * Unlike the non-UTF-8 case, the macro for determining if a
9997          * string is a multi-char fold requires all the characters to
9998          * already be folded.  This is because of all the complications
9999          * if not.  Note that they are folded anyway, except in EXACTFL
10000          * nodes.  Like the non-UTF case above, we punt if the node
10001          * begins with a multi-char fold  */
10002
10003         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10004             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10005         }
10006         else {  /* Single char fold */
10007
10008             /* It matches all the things that fold to it, which are
10009              * found in PL_utf8_foldclosures (including itself) */
10010             invlist = add_cp_to_invlist(invlist, uc);
10011             if (! PL_utf8_foldclosures)
10012                 _load_PL_utf8_foldclosures();
10013             if ((listp = hv_fetch(PL_utf8_foldclosures,
10014                                 (char *) s, foldlen, FALSE)))
10015             {
10016                 AV* list = (AV*) *listp;
10017                 IV k;
10018                 for (k = 0; k <= av_tindex_nomg(list); k++) {
10019                     SV** c_p = av_fetch(list, k, FALSE);
10020                     UV c;
10021                     assert(c_p);
10022
10023                     c = SvUV(*c_p);
10024
10025                     /* /aa doesn't allow folds between ASCII and non- */
10026                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
10027                         && isASCII(c) != isASCII(uc))
10028                     {
10029                         continue;
10030                     }
10031
10032                     invlist = add_cp_to_invlist(invlist, c);
10033                 }
10034             }
10035         }
10036     }
10037
10038     return invlist;
10039 }
10040
10041 #undef HEADER_LENGTH
10042 #undef TO_INTERNAL_SIZE
10043 #undef FROM_INTERNAL_SIZE
10044 #undef INVLIST_VERSION_ID
10045
10046 /* End of inversion list object */
10047
10048 STATIC void
10049 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10050 {
10051     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10052      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10053      * should point to the first flag; it is updated on output to point to the
10054      * final ')' or ':'.  There needs to be at least one flag, or this will
10055      * abort */
10056
10057     /* for (?g), (?gc), and (?o) warnings; warning
10058        about (?c) will warn about (?g) -- japhy    */
10059
10060 #define WASTED_O  0x01
10061 #define WASTED_G  0x02
10062 #define WASTED_C  0x04
10063 #define WASTED_GC (WASTED_G|WASTED_C)
10064     I32 wastedflags = 0x00;
10065     U32 posflags = 0, negflags = 0;
10066     U32 *flagsp = &posflags;
10067     char has_charset_modifier = '\0';
10068     regex_charset cs;
10069     bool has_use_defaults = FALSE;
10070     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10071     int x_mod_count = 0;
10072
10073     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10074
10075     /* '^' as an initial flag sets certain defaults */
10076     if (UCHARAT(RExC_parse) == '^') {
10077         RExC_parse++;
10078         has_use_defaults = TRUE;
10079         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10080         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10081                                         ? REGEX_UNICODE_CHARSET
10082                                         : REGEX_DEPENDS_CHARSET);
10083     }
10084
10085     cs = get_regex_charset(RExC_flags);
10086     if (cs == REGEX_DEPENDS_CHARSET
10087         && (RExC_utf8 || RExC_uni_semantics))
10088     {
10089         cs = REGEX_UNICODE_CHARSET;
10090     }
10091
10092     while (RExC_parse < RExC_end) {
10093         /* && strchr("iogcmsx", *RExC_parse) */
10094         /* (?g), (?gc) and (?o) are useless here
10095            and must be globally applied -- japhy */
10096         switch (*RExC_parse) {
10097
10098             /* Code for the imsxn flags */
10099             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10100
10101             case LOCALE_PAT_MOD:
10102                 if (has_charset_modifier) {
10103                     goto excess_modifier;
10104                 }
10105                 else if (flagsp == &negflags) {
10106                     goto neg_modifier;
10107                 }
10108                 cs = REGEX_LOCALE_CHARSET;
10109                 has_charset_modifier = LOCALE_PAT_MOD;
10110                 break;
10111             case UNICODE_PAT_MOD:
10112                 if (has_charset_modifier) {
10113                     goto excess_modifier;
10114                 }
10115                 else if (flagsp == &negflags) {
10116                     goto neg_modifier;
10117                 }
10118                 cs = REGEX_UNICODE_CHARSET;
10119                 has_charset_modifier = UNICODE_PAT_MOD;
10120                 break;
10121             case ASCII_RESTRICT_PAT_MOD:
10122                 if (flagsp == &negflags) {
10123                     goto neg_modifier;
10124                 }
10125                 if (has_charset_modifier) {
10126                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10127                         goto excess_modifier;
10128                     }
10129                     /* Doubled modifier implies more restricted */
10130                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10131                 }
10132                 else {
10133                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10134                 }
10135                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10136                 break;
10137             case DEPENDS_PAT_MOD:
10138                 if (has_use_defaults) {
10139                     goto fail_modifiers;
10140                 }
10141                 else if (flagsp == &negflags) {
10142                     goto neg_modifier;
10143                 }
10144                 else if (has_charset_modifier) {
10145                     goto excess_modifier;
10146                 }
10147
10148                 /* The dual charset means unicode semantics if the
10149                  * pattern (or target, not known until runtime) are
10150                  * utf8, or something in the pattern indicates unicode
10151                  * semantics */
10152                 cs = (RExC_utf8 || RExC_uni_semantics)
10153                      ? REGEX_UNICODE_CHARSET
10154                      : REGEX_DEPENDS_CHARSET;
10155                 has_charset_modifier = DEPENDS_PAT_MOD;
10156                 break;
10157               excess_modifier:
10158                 RExC_parse++;
10159                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10160                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10161                 }
10162                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10163                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10164                                         *(RExC_parse - 1));
10165                 }
10166                 else {
10167                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10168                 }
10169                 NOT_REACHED; /*NOTREACHED*/
10170               neg_modifier:
10171                 RExC_parse++;
10172                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10173                                     *(RExC_parse - 1));
10174                 NOT_REACHED; /*NOTREACHED*/
10175             case ONCE_PAT_MOD: /* 'o' */
10176             case GLOBAL_PAT_MOD: /* 'g' */
10177                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10178                     const I32 wflagbit = *RExC_parse == 'o'
10179                                          ? WASTED_O
10180                                          : WASTED_G;
10181                     if (! (wastedflags & wflagbit) ) {
10182                         wastedflags |= wflagbit;
10183                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10184                         vWARN5(
10185                             RExC_parse + 1,
10186                             "Useless (%s%c) - %suse /%c modifier",
10187                             flagsp == &negflags ? "?-" : "?",
10188                             *RExC_parse,
10189                             flagsp == &negflags ? "don't " : "",
10190                             *RExC_parse
10191                         );
10192                     }
10193                 }
10194                 break;
10195
10196             case CONTINUE_PAT_MOD: /* 'c' */
10197                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10198                     if (! (wastedflags & WASTED_C) ) {
10199                         wastedflags |= WASTED_GC;
10200                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10201                         vWARN3(
10202                             RExC_parse + 1,
10203                             "Useless (%sc) - %suse /gc modifier",
10204                             flagsp == &negflags ? "?-" : "?",
10205                             flagsp == &negflags ? "don't " : ""
10206                         );
10207                     }
10208                 }
10209                 break;
10210             case KEEPCOPY_PAT_MOD: /* 'p' */
10211                 if (flagsp == &negflags) {
10212                     if (PASS2)
10213                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10214                 } else {
10215                     *flagsp |= RXf_PMf_KEEPCOPY;
10216                 }
10217                 break;
10218             case '-':
10219                 /* A flag is a default iff it is following a minus, so
10220                  * if there is a minus, it means will be trying to
10221                  * re-specify a default which is an error */
10222                 if (has_use_defaults || flagsp == &negflags) {
10223                     goto fail_modifiers;
10224                 }
10225                 flagsp = &negflags;
10226                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10227                 break;
10228             case ':':
10229             case ')':
10230                 RExC_flags |= posflags;
10231                 RExC_flags &= ~negflags;
10232                 set_regex_charset(&RExC_flags, cs);
10233                 if (RExC_flags & RXf_PMf_FOLD) {
10234                     RExC_contains_i = 1;
10235                 }
10236                 if (PASS2) {
10237                     STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
10238                 }
10239                 return;
10240                 /*NOTREACHED*/
10241             default:
10242               fail_modifiers:
10243                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10244                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10245                 vFAIL2utf8f("Sequence (%"UTF8f"...) not recognized",
10246                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10247                 NOT_REACHED; /*NOTREACHED*/
10248         }
10249
10250         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10251     }
10252
10253     vFAIL("Sequence (?... not terminated");
10254 }
10255
10256 /*
10257  - reg - regular expression, i.e. main body or parenthesized thing
10258  *
10259  * Caller must absorb opening parenthesis.
10260  *
10261  * Combining parenthesis handling with the base level of regular expression
10262  * is a trifle forced, but the need to tie the tails of the branches to what
10263  * follows makes it hard to avoid.
10264  */
10265 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10266 #ifdef DEBUGGING
10267 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10268 #else
10269 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10270 #endif
10271
10272 PERL_STATIC_INLINE regnode *
10273 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10274                              I32 *flagp,
10275                              char * parse_start,
10276                              char ch
10277                       )
10278 {
10279     regnode *ret;
10280     char* name_start = RExC_parse;
10281     U32 num = 0;
10282     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10283                                             ? REG_RSN_RETURN_NULL
10284                                             : REG_RSN_RETURN_DATA);
10285     GET_RE_DEBUG_FLAGS_DECL;
10286
10287     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10288
10289     if (RExC_parse == name_start || *RExC_parse != ch) {
10290         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10291         vFAIL2("Sequence %.3s... not terminated",parse_start);
10292     }
10293
10294     if (!SIZE_ONLY) {
10295         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10296         RExC_rxi->data->data[num]=(void*)sv_dat;
10297         SvREFCNT_inc_simple_void(sv_dat);
10298     }
10299     RExC_sawback = 1;
10300     ret = reganode(pRExC_state,
10301                    ((! FOLD)
10302                      ? NREF
10303                      : (ASCII_FOLD_RESTRICTED)
10304                        ? NREFFA
10305                        : (AT_LEAST_UNI_SEMANTICS)
10306                          ? NREFFU
10307                          : (LOC)
10308                            ? NREFFL
10309                            : NREFF),
10310                     num);
10311     *flagp |= HASWIDTH;
10312
10313     Set_Node_Offset(ret, parse_start+1);
10314     Set_Node_Cur_Length(ret, parse_start);
10315
10316     nextchar(pRExC_state);
10317     return ret;
10318 }
10319
10320 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10321    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10322    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10323    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10324    NULL, which cannot happen.  */
10325 STATIC regnode *
10326 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10327     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10328      * 2 is like 1, but indicates that nextchar() has been called to advance
10329      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10330      * this flag alerts us to the need to check for that */
10331 {
10332     regnode *ret;               /* Will be the head of the group. */
10333     regnode *br;
10334     regnode *lastbr;
10335     regnode *ender = NULL;
10336     I32 parno = 0;
10337     I32 flags;
10338     U32 oregflags = RExC_flags;
10339     bool have_branch = 0;
10340     bool is_open = 0;
10341     I32 freeze_paren = 0;
10342     I32 after_freeze = 0;
10343     I32 num; /* numeric backreferences */
10344
10345     char * parse_start = RExC_parse; /* MJD */
10346     char * const oregcomp_parse = RExC_parse;
10347
10348     GET_RE_DEBUG_FLAGS_DECL;
10349
10350     PERL_ARGS_ASSERT_REG;
10351     DEBUG_PARSE("reg ");
10352
10353     *flagp = 0;                         /* Tentatively. */
10354
10355     /* Having this true makes it feasible to have a lot fewer tests for the
10356      * parse pointer being in scope.  For example, we can write
10357      *      while(isFOO(*RExC_parse)) RExC_parse++;
10358      * instead of
10359      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10360      */
10361     assert(*RExC_end == '\0');
10362
10363     /* Make an OPEN node, if parenthesized. */
10364     if (paren) {
10365
10366         /* Under /x, space and comments can be gobbled up between the '(' and
10367          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10368          * intervening space, as the sequence is a token, and a token should be
10369          * indivisible */
10370         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
10371
10372         if (RExC_parse >= RExC_end) {
10373             vFAIL("Unmatched (");
10374         }
10375
10376         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
10377             char *start_verb = RExC_parse + 1;
10378             STRLEN verb_len;
10379             char *start_arg = NULL;
10380             unsigned char op = 0;
10381             int arg_required = 0;
10382             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10383
10384             if (has_intervening_patws) {
10385                 RExC_parse++;   /* past the '*' */
10386                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10387             }
10388             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10389                 if ( *RExC_parse == ':' ) {
10390                     start_arg = RExC_parse + 1;
10391                     break;
10392                 }
10393                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10394             }
10395             verb_len = RExC_parse - start_verb;
10396             if ( start_arg ) {
10397                 if (RExC_parse >= RExC_end) {
10398                     goto unterminated_verb_pattern;
10399                 }
10400                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10401                 while ( RExC_parse < RExC_end && *RExC_parse != ')' )
10402                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10403                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10404                   unterminated_verb_pattern:
10405                     vFAIL("Unterminated verb pattern argument");
10406                 if ( RExC_parse == start_arg )
10407                     start_arg = NULL;
10408             } else {
10409                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10410                     vFAIL("Unterminated verb pattern");
10411             }
10412
10413             /* Here, we know that RExC_parse < RExC_end */
10414
10415             switch ( *start_verb ) {
10416             case 'A':  /* (*ACCEPT) */
10417                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10418                     op = ACCEPT;
10419                     internal_argval = RExC_nestroot;
10420                 }
10421                 break;
10422             case 'C':  /* (*COMMIT) */
10423                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10424                     op = COMMIT;
10425                 break;
10426             case 'F':  /* (*FAIL) */
10427                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10428                     op = OPFAIL;
10429                 }
10430                 break;
10431             case ':':  /* (*:NAME) */
10432             case 'M':  /* (*MARK:NAME) */
10433                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10434                     op = MARKPOINT;
10435                     arg_required = 1;
10436                 }
10437                 break;
10438             case 'P':  /* (*PRUNE) */
10439                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10440                     op = PRUNE;
10441                 break;
10442             case 'S':   /* (*SKIP) */
10443                 if ( memEQs(start_verb,verb_len,"SKIP") )
10444                     op = SKIP;
10445                 break;
10446             case 'T':  /* (*THEN) */
10447                 /* [19:06] <TimToady> :: is then */
10448                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10449                     op = CUTGROUP;
10450                     RExC_seen |= REG_CUTGROUP_SEEN;
10451                 }
10452                 break;
10453             }
10454             if ( ! op ) {
10455                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10456                 vFAIL2utf8f(
10457                     "Unknown verb pattern '%"UTF8f"'",
10458                     UTF8fARG(UTF, verb_len, start_verb));
10459             }
10460             if ( arg_required && !start_arg ) {
10461                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
10462                     verb_len, start_verb);
10463             }
10464             if (internal_argval == -1) {
10465                 ret = reganode(pRExC_state, op, 0);
10466             } else {
10467                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
10468             }
10469             RExC_seen |= REG_VERBARG_SEEN;
10470             if ( ! SIZE_ONLY ) {
10471                 if (start_arg) {
10472                     SV *sv = newSVpvn( start_arg,
10473                                        RExC_parse - start_arg);
10474                     ARG(ret) = add_data( pRExC_state,
10475                                          STR_WITH_LEN("S"));
10476                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
10477                     ret->flags = 1;
10478                 } else {
10479                     ret->flags = 0;
10480                 }
10481                 if ( internal_argval != -1 )
10482                     ARG2L_SET(ret, internal_argval);
10483             }
10484             nextchar(pRExC_state);
10485             return ret;
10486         }
10487         else if (*RExC_parse == '?') { /* (?...) */
10488             bool is_logical = 0;
10489             const char * const seqstart = RExC_parse;
10490             const char * endptr;
10491             if (has_intervening_patws) {
10492                 RExC_parse++;
10493                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
10494             }
10495
10496             RExC_parse++;           /* past the '?' */
10497             paren = *RExC_parse;    /* might be a trailing NUL, if not
10498                                        well-formed */
10499             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10500             if (RExC_parse > RExC_end) {
10501                 paren = '\0';
10502             }
10503             ret = NULL;                 /* For look-ahead/behind. */
10504             switch (paren) {
10505
10506             case 'P':   /* (?P...) variants for those used to PCRE/Python */
10507                 paren = *RExC_parse;
10508                 if ( paren == '<') {    /* (?P<...>) named capture */
10509                     RExC_parse++;
10510                     if (RExC_parse >= RExC_end) {
10511                         vFAIL("Sequence (?P<... not terminated");
10512                     }
10513                     goto named_capture;
10514                 }
10515                 else if (paren == '>') {   /* (?P>name) named recursion */
10516                     RExC_parse++;
10517                     if (RExC_parse >= RExC_end) {
10518                         vFAIL("Sequence (?P>... not terminated");
10519                     }
10520                     goto named_recursion;
10521                 }
10522                 else if (paren == '=') {   /* (?P=...)  named backref */
10523                     RExC_parse++;
10524                     return handle_named_backref(pRExC_state, flagp,
10525                                                 parse_start, ')');
10526                 }
10527                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10528                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10529                 vFAIL3("Sequence (%.*s...) not recognized",
10530                                 RExC_parse-seqstart, seqstart);
10531                 NOT_REACHED; /*NOTREACHED*/
10532             case '<':           /* (?<...) */
10533                 if (*RExC_parse == '!')
10534                     paren = ',';
10535                 else if (*RExC_parse != '=')
10536               named_capture:
10537                 {               /* (?<...>) */
10538                     char *name_start;
10539                     SV *svname;
10540                     paren= '>';
10541                 /* FALLTHROUGH */
10542             case '\'':          /* (?'...') */
10543                     name_start = RExC_parse;
10544                     svname = reg_scan_name(pRExC_state,
10545                         SIZE_ONLY    /* reverse test from the others */
10546                         ? REG_RSN_RETURN_NAME
10547                         : REG_RSN_RETURN_NULL);
10548                     if (   RExC_parse == name_start
10549                         || RExC_parse >= RExC_end
10550                         || *RExC_parse != paren)
10551                     {
10552                         vFAIL2("Sequence (?%c... not terminated",
10553                             paren=='>' ? '<' : paren);
10554                     }
10555                     if (SIZE_ONLY) {
10556                         HE *he_str;
10557                         SV *sv_dat = NULL;
10558                         if (!svname) /* shouldn't happen */
10559                             Perl_croak(aTHX_
10560                                 "panic: reg_scan_name returned NULL");
10561                         if (!RExC_paren_names) {
10562                             RExC_paren_names= newHV();
10563                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10564 #ifdef DEBUGGING
10565                             RExC_paren_name_list= newAV();
10566                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10567 #endif
10568                         }
10569                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10570                         if ( he_str )
10571                             sv_dat = HeVAL(he_str);
10572                         if ( ! sv_dat ) {
10573                             /* croak baby croak */
10574                             Perl_croak(aTHX_
10575                                 "panic: paren_name hash element allocation failed");
10576                         } else if ( SvPOK(sv_dat) ) {
10577                             /* (?|...) can mean we have dupes so scan to check
10578                                its already been stored. Maybe a flag indicating
10579                                we are inside such a construct would be useful,
10580                                but the arrays are likely to be quite small, so
10581                                for now we punt -- dmq */
10582                             IV count = SvIV(sv_dat);
10583                             I32 *pv = (I32*)SvPVX(sv_dat);
10584                             IV i;
10585                             for ( i = 0 ; i < count ; i++ ) {
10586                                 if ( pv[i] == RExC_npar ) {
10587                                     count = 0;
10588                                     break;
10589                                 }
10590                             }
10591                             if ( count ) {
10592                                 pv = (I32*)SvGROW(sv_dat,
10593                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10594                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10595                                 pv[count] = RExC_npar;
10596                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10597                             }
10598                         } else {
10599                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10600                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10601                                                                 sizeof(I32));
10602                             SvIOK_on(sv_dat);
10603                             SvIV_set(sv_dat, 1);
10604                         }
10605 #ifdef DEBUGGING
10606                         /* Yes this does cause a memory leak in debugging Perls
10607                          * */
10608                         if (!av_store(RExC_paren_name_list,
10609                                       RExC_npar, SvREFCNT_inc(svname)))
10610                             SvREFCNT_dec_NN(svname);
10611 #endif
10612
10613                         /*sv_dump(sv_dat);*/
10614                     }
10615                     nextchar(pRExC_state);
10616                     paren = 1;
10617                     goto capturing_parens;
10618                 }
10619                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10620                 RExC_in_lookbehind++;
10621                 RExC_parse++;
10622                 assert(RExC_parse < RExC_end);
10623                 /* FALLTHROUGH */
10624             case '=':           /* (?=...) */
10625                 RExC_seen_zerolen++;
10626                 break;
10627             case '!':           /* (?!...) */
10628                 RExC_seen_zerolen++;
10629                 /* check if we're really just a "FAIL" assertion */
10630                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
10631                                         FALSE /* Don't force to /x */ );
10632                 if (*RExC_parse == ')') {
10633                     ret=reganode(pRExC_state, OPFAIL, 0);
10634                     nextchar(pRExC_state);
10635                     return ret;
10636                 }
10637                 break;
10638             case '|':           /* (?|...) */
10639                 /* branch reset, behave like a (?:...) except that
10640                    buffers in alternations share the same numbers */
10641                 paren = ':';
10642                 after_freeze = freeze_paren = RExC_npar;
10643                 break;
10644             case ':':           /* (?:...) */
10645             case '>':           /* (?>...) */
10646                 break;
10647             case '$':           /* (?$...) */
10648             case '@':           /* (?@...) */
10649                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10650                 break;
10651             case '0' :           /* (?0) */
10652             case 'R' :           /* (?R) */
10653                 if (RExC_parse == RExC_end || *RExC_parse != ')')
10654                     FAIL("Sequence (?R) not terminated");
10655                 num = 0;
10656                 RExC_seen |= REG_RECURSE_SEEN;
10657                 *flagp |= POSTPONED;
10658                 goto gen_recurse_regop;
10659                 /*notreached*/
10660             /* named and numeric backreferences */
10661             case '&':            /* (?&NAME) */
10662                 parse_start = RExC_parse - 1;
10663               named_recursion:
10664                 {
10665                     SV *sv_dat = reg_scan_name(pRExC_state,
10666                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10667                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10668                 }
10669                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
10670                     vFAIL("Sequence (?&... not terminated");
10671                 goto gen_recurse_regop;
10672                 /* NOTREACHED */
10673             case '+':
10674                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10675                     RExC_parse++;
10676                     vFAIL("Illegal pattern");
10677                 }
10678                 goto parse_recursion;
10679                 /* NOTREACHED*/
10680             case '-': /* (?-1) */
10681                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10682                     RExC_parse--; /* rewind to let it be handled later */
10683                     goto parse_flags;
10684                 }
10685                 /* FALLTHROUGH */
10686             case '1': case '2': case '3': case '4': /* (?1) */
10687             case '5': case '6': case '7': case '8': case '9':
10688                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
10689               parse_recursion:
10690                 {
10691                     bool is_neg = FALSE;
10692                     UV unum;
10693                     parse_start = RExC_parse - 1; /* MJD */
10694                     if (*RExC_parse == '-') {
10695                         RExC_parse++;
10696                         is_neg = TRUE;
10697                     }
10698                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10699                         && unum <= I32_MAX
10700                     ) {
10701                         num = (I32)unum;
10702                         RExC_parse = (char*)endptr;
10703                     } else
10704                         num = I32_MAX;
10705                     if (is_neg) {
10706                         /* Some limit for num? */
10707                         num = -num;
10708                     }
10709                 }
10710                 if (*RExC_parse!=')')
10711                     vFAIL("Expecting close bracket");
10712
10713               gen_recurse_regop:
10714                 if ( paren == '-' ) {
10715                     /*
10716                     Diagram of capture buffer numbering.
10717                     Top line is the normal capture buffer numbers
10718                     Bottom line is the negative indexing as from
10719                     the X (the (?-2))
10720
10721                     +   1 2    3 4 5 X          6 7
10722                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
10723                     -   5 4    3 2 1 X          x x
10724
10725                     */
10726                     num = RExC_npar + num;
10727                     if (num < 1)  {
10728                         RExC_parse++;
10729                         vFAIL("Reference to nonexistent group");
10730                     }
10731                 } else if ( paren == '+' ) {
10732                     num = RExC_npar + num - 1;
10733                 }
10734                 /* We keep track how many GOSUB items we have produced.
10735                    To start off the ARG2L() of the GOSUB holds its "id",
10736                    which is used later in conjunction with RExC_recurse
10737                    to calculate the offset we need to jump for the GOSUB,
10738                    which it will store in the final representation.
10739                    We have to defer the actual calculation until much later
10740                    as the regop may move.
10741                  */
10742
10743                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
10744                 if (!SIZE_ONLY) {
10745                     if (num > (I32)RExC_rx->nparens) {
10746                         RExC_parse++;
10747                         vFAIL("Reference to nonexistent group");
10748                     }
10749                     RExC_recurse_count++;
10750                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
10751                         "%*s%*s Recurse #%"UVuf" to %"IVdf"\n",
10752                               22, "|    |", (int)(depth * 2 + 1), "",
10753                               (UV)ARG(ret), (IV)ARG2L(ret)));
10754                 }
10755                 RExC_seen |= REG_RECURSE_SEEN;
10756
10757                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
10758                 Set_Node_Offset(ret, parse_start); /* MJD */
10759
10760                 *flagp |= POSTPONED;
10761                 assert(*RExC_parse == ')');
10762                 nextchar(pRExC_state);
10763                 return ret;
10764
10765             /* NOTREACHED */
10766
10767             case '?':           /* (??...) */
10768                 is_logical = 1;
10769                 if (*RExC_parse != '{') {
10770                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
10771                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10772                     vFAIL2utf8f(
10773                         "Sequence (%"UTF8f"...) not recognized",
10774                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10775                     NOT_REACHED; /*NOTREACHED*/
10776                 }
10777                 *flagp |= POSTPONED;
10778                 paren = '{';
10779                 RExC_parse++;
10780                 /* FALLTHROUGH */
10781             case '{':           /* (?{...}) */
10782             {
10783                 U32 n = 0;
10784                 struct reg_code_block *cb;
10785
10786                 RExC_seen_zerolen++;
10787
10788                 if (   !pRExC_state->num_code_blocks
10789                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
10790                     || pRExC_state->code_blocks[pRExC_state->code_index].start
10791                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
10792                             - RExC_start)
10793                 ) {
10794                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
10795                         FAIL("panic: Sequence (?{...}): no code block found\n");
10796                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
10797                 }
10798                 /* this is a pre-compiled code block (?{...}) */
10799                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
10800                 RExC_parse = RExC_start + cb->end;
10801                 if (!SIZE_ONLY) {
10802                     OP *o = cb->block;
10803                     if (cb->src_regex) {
10804                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
10805                         RExC_rxi->data->data[n] =
10806                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
10807                         RExC_rxi->data->data[n+1] = (void*)o;
10808                     }
10809                     else {
10810                         n = add_data(pRExC_state,
10811                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
10812                         RExC_rxi->data->data[n] = (void*)o;
10813                     }
10814                 }
10815                 pRExC_state->code_index++;
10816                 nextchar(pRExC_state);
10817
10818                 if (is_logical) {
10819                     regnode *eval;
10820                     ret = reg_node(pRExC_state, LOGICAL);
10821
10822                     eval = reg2Lanode(pRExC_state, EVAL,
10823                                        n,
10824
10825                                        /* for later propagation into (??{})
10826                                         * return value */
10827                                        RExC_flags & RXf_PMf_COMPILETIME
10828                                       );
10829                     if (!SIZE_ONLY) {
10830                         ret->flags = 2;
10831                     }
10832                     REGTAIL(pRExC_state, ret, eval);
10833                     /* deal with the length of this later - MJD */
10834                     return ret;
10835                 }
10836                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
10837                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
10838                 Set_Node_Offset(ret, parse_start);
10839                 return ret;
10840             }
10841             case '(':           /* (?(?{...})...) and (?(?=...)...) */
10842             {
10843                 int is_define= 0;
10844                 const int DEFINE_len = sizeof("DEFINE") - 1;
10845                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
10846                     if (   RExC_parse < RExC_end - 1
10847                         && (   RExC_parse[1] == '='
10848                             || RExC_parse[1] == '!'
10849                             || RExC_parse[1] == '<'
10850                             || RExC_parse[1] == '{')
10851                     ) { /* Lookahead or eval. */
10852                         I32 flag;
10853                         regnode *tail;
10854
10855                         ret = reg_node(pRExC_state, LOGICAL);
10856                         if (!SIZE_ONLY)
10857                             ret->flags = 1;
10858
10859                         tail = reg(pRExC_state, 1, &flag, depth+1);
10860                         if (flag & (RESTART_PASS1|NEED_UTF8)) {
10861                             *flagp = flag & (RESTART_PASS1|NEED_UTF8);
10862                             return NULL;
10863                         }
10864                         REGTAIL(pRExC_state, ret, tail);
10865                         goto insert_if;
10866                     }
10867                     /* Fall through to ‘Unknown switch condition’ at the
10868                        end of the if/else chain. */
10869                 }
10870                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
10871                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
10872                 {
10873                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
10874                     char *name_start= RExC_parse++;
10875                     U32 num = 0;
10876                     SV *sv_dat=reg_scan_name(pRExC_state,
10877                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10878                     if (   RExC_parse == name_start
10879                         || RExC_parse >= RExC_end
10880                         || *RExC_parse != ch)
10881                     {
10882                         vFAIL2("Sequence (?(%c... not terminated",
10883                             (ch == '>' ? '<' : ch));
10884                     }
10885                     RExC_parse++;
10886                     if (!SIZE_ONLY) {
10887                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10888                         RExC_rxi->data->data[num]=(void*)sv_dat;
10889                         SvREFCNT_inc_simple_void(sv_dat);
10890                     }
10891                     ret = reganode(pRExC_state,NGROUPP,num);
10892                     goto insert_if_check_paren;
10893                 }
10894                 else if (RExC_end - RExC_parse >= DEFINE_len
10895                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
10896                 {
10897                     ret = reganode(pRExC_state,DEFINEP,0);
10898                     RExC_parse += DEFINE_len;
10899                     is_define = 1;
10900                     goto insert_if_check_paren;
10901                 }
10902                 else if (RExC_parse[0] == 'R') {
10903                     RExC_parse++;
10904                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
10905                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
10906                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
10907                      */
10908                     parno = 0;
10909                     if (RExC_parse[0] == '0') {
10910                         parno = 1;
10911                         RExC_parse++;
10912                     }
10913                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10914                         UV uv;
10915                         if (grok_atoUV(RExC_parse, &uv, &endptr)
10916                             && uv <= I32_MAX
10917                         ) {
10918                             parno = (I32)uv + 1;
10919                             RExC_parse = (char*)endptr;
10920                         }
10921                         /* else "Switch condition not recognized" below */
10922                     } else if (RExC_parse[0] == '&') {
10923                         SV *sv_dat;
10924                         RExC_parse++;
10925                         sv_dat = reg_scan_name(pRExC_state,
10926                             SIZE_ONLY
10927                             ? REG_RSN_RETURN_NULL
10928                             : REG_RSN_RETURN_DATA);
10929
10930                         /* we should only have a false sv_dat when
10931                          * SIZE_ONLY is true, and we always have false
10932                          * sv_dat when SIZE_ONLY is true.
10933                          * reg_scan_name() will VFAIL() if the name is
10934                          * unknown when SIZE_ONLY is false, and otherwise
10935                          * will return something, and when SIZE_ONLY is
10936                          * true, reg_scan_name() just parses the string,
10937                          * and doesnt return anything. (in theory) */
10938                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
10939
10940                         if (sv_dat)
10941                             parno = 1 + *((I32 *)SvPVX(sv_dat));
10942                     }
10943                     ret = reganode(pRExC_state,INSUBP,parno);
10944                     goto insert_if_check_paren;
10945                 }
10946                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10947                     /* (?(1)...) */
10948                     char c;
10949                     UV uv;
10950                     if (grok_atoUV(RExC_parse, &uv, &endptr)
10951                         && uv <= I32_MAX
10952                     ) {
10953                         parno = (I32)uv;
10954                         RExC_parse = (char*)endptr;
10955                     }
10956                     else {
10957                         vFAIL("panic: grok_atoUV returned FALSE");
10958                     }
10959                     ret = reganode(pRExC_state, GROUPP, parno);
10960
10961                  insert_if_check_paren:
10962                     if (UCHARAT(RExC_parse) != ')') {
10963                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10964                         vFAIL("Switch condition not recognized");
10965                     }
10966                     nextchar(pRExC_state);
10967                   insert_if:
10968                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
10969                     br = regbranch(pRExC_state, &flags, 1,depth+1);
10970                     if (br == NULL) {
10971                         if (flags & (RESTART_PASS1|NEED_UTF8)) {
10972                             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
10973                             return NULL;
10974                         }
10975                         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10976                               (UV) flags);
10977                     } else
10978                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
10979                                                           LONGJMP, 0));
10980                     c = UCHARAT(RExC_parse);
10981                     nextchar(pRExC_state);
10982                     if (flags&HASWIDTH)
10983                         *flagp |= HASWIDTH;
10984                     if (c == '|') {
10985                         if (is_define)
10986                             vFAIL("(?(DEFINE)....) does not allow branches");
10987
10988                         /* Fake one for optimizer.  */
10989                         lastbr = reganode(pRExC_state, IFTHEN, 0);
10990
10991                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
10992                             if (flags & (RESTART_PASS1|NEED_UTF8)) {
10993                                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
10994                                 return NULL;
10995                             }
10996                             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10997                                   (UV) flags);
10998                         }
10999                         REGTAIL(pRExC_state, ret, lastbr);
11000                         if (flags&HASWIDTH)
11001                             *flagp |= HASWIDTH;
11002                         c = UCHARAT(RExC_parse);
11003                         nextchar(pRExC_state);
11004                     }
11005                     else
11006                         lastbr = NULL;
11007                     if (c != ')') {
11008                         if (RExC_parse >= RExC_end)
11009                             vFAIL("Switch (?(condition)... not terminated");
11010                         else
11011                             vFAIL("Switch (?(condition)... contains too many branches");
11012                     }
11013                     ender = reg_node(pRExC_state, TAIL);
11014                     REGTAIL(pRExC_state, br, ender);
11015                     if (lastbr) {
11016                         REGTAIL(pRExC_state, lastbr, ender);
11017                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11018                     }
11019                     else
11020                         REGTAIL(pRExC_state, ret, ender);
11021                     RExC_size++; /* XXX WHY do we need this?!!
11022                                     For large programs it seems to be required
11023                                     but I can't figure out why. -- dmq*/
11024                     return ret;
11025                 }
11026                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11027                 vFAIL("Unknown switch condition (?(...))");
11028             }
11029             case '[':           /* (?[ ... ]) */
11030                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
11031                                          oregcomp_parse);
11032             case 0: /* A NUL */
11033                 RExC_parse--; /* for vFAIL to print correctly */
11034                 vFAIL("Sequence (? incomplete");
11035                 break;
11036             default: /* e.g., (?i) */
11037                 RExC_parse = (char *) seqstart + 1;
11038               parse_flags:
11039                 parse_lparen_question_flags(pRExC_state);
11040                 if (UCHARAT(RExC_parse) != ':') {
11041                     if (RExC_parse < RExC_end)
11042                         nextchar(pRExC_state);
11043                     *flagp = TRYAGAIN;
11044                     return NULL;
11045                 }
11046                 paren = ':';
11047                 nextchar(pRExC_state);
11048                 ret = NULL;
11049                 goto parse_rest;
11050             } /* end switch */
11051         }
11052         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11053           capturing_parens:
11054             parno = RExC_npar;
11055             RExC_npar++;
11056
11057             ret = reganode(pRExC_state, OPEN, parno);
11058             if (!SIZE_ONLY ){
11059                 if (!RExC_nestroot)
11060                     RExC_nestroot = parno;
11061                 if (RExC_open_parens && !RExC_open_parens[parno])
11062                 {
11063                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11064                         "%*s%*s Setting open paren #%"IVdf" to %d\n",
11065                         22, "|    |", (int)(depth * 2 + 1), "",
11066                         (IV)parno, REG_NODE_NUM(ret)));
11067                     RExC_open_parens[parno]= ret;
11068                 }
11069             }
11070             Set_Node_Length(ret, 1); /* MJD */
11071             Set_Node_Offset(ret, RExC_parse); /* MJD */
11072             is_open = 1;
11073         } else {
11074             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11075             paren = ':';
11076             ret = NULL;
11077         }
11078     }
11079     else                        /* ! paren */
11080         ret = NULL;
11081
11082    parse_rest:
11083     /* Pick up the branches, linking them together. */
11084     parse_start = RExC_parse;   /* MJD */
11085     br = regbranch(pRExC_state, &flags, 1,depth+1);
11086
11087     /*     branch_len = (paren != 0); */
11088
11089     if (br == NULL) {
11090         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11091             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11092             return NULL;
11093         }
11094         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
11095     }
11096     if (*RExC_parse == '|') {
11097         if (!SIZE_ONLY && RExC_extralen) {
11098             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11099         }
11100         else {                  /* MJD */
11101             reginsert(pRExC_state, BRANCH, br, depth+1);
11102             Set_Node_Length(br, paren != 0);
11103             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11104         }
11105         have_branch = 1;
11106         if (SIZE_ONLY)
11107             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11108     }
11109     else if (paren == ':') {
11110         *flagp |= flags&SIMPLE;
11111     }
11112     if (is_open) {                              /* Starts with OPEN. */
11113         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11114     }
11115     else if (paren != '?')              /* Not Conditional */
11116         ret = br;
11117     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11118     lastbr = br;
11119     while (*RExC_parse == '|') {
11120         if (!SIZE_ONLY && RExC_extralen) {
11121             ender = reganode(pRExC_state, LONGJMP,0);
11122
11123             /* Append to the previous. */
11124             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11125         }
11126         if (SIZE_ONLY)
11127             RExC_extralen += 2;         /* Account for LONGJMP. */
11128         nextchar(pRExC_state);
11129         if (freeze_paren) {
11130             if (RExC_npar > after_freeze)
11131                 after_freeze = RExC_npar;
11132             RExC_npar = freeze_paren;
11133         }
11134         br = regbranch(pRExC_state, &flags, 0, depth+1);
11135
11136         if (br == NULL) {
11137             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11138                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11139                 return NULL;
11140             }
11141             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
11142         }
11143         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11144         lastbr = br;
11145         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11146     }
11147
11148     if (have_branch || paren != ':') {
11149         /* Make a closing node, and hook it on the end. */
11150         switch (paren) {
11151         case ':':
11152             ender = reg_node(pRExC_state, TAIL);
11153             break;
11154         case 1: case 2:
11155             ender = reganode(pRExC_state, CLOSE, parno);
11156             if ( RExC_close_parens ) {
11157                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11158                         "%*s%*s Setting close paren #%"IVdf" to %d\n",
11159                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11160                 RExC_close_parens[parno]= ender;
11161                 if (RExC_nestroot == parno)
11162                     RExC_nestroot = 0;
11163             }
11164             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11165             Set_Node_Length(ender,1); /* MJD */
11166             break;
11167         case '<':
11168         case ',':
11169         case '=':
11170         case '!':
11171             *flagp &= ~HASWIDTH;
11172             /* FALLTHROUGH */
11173         case '>':
11174             ender = reg_node(pRExC_state, SUCCEED);
11175             break;
11176         case 0:
11177             ender = reg_node(pRExC_state, END);
11178             if (!SIZE_ONLY) {
11179                 assert(!RExC_end_op); /* there can only be one! */
11180                 RExC_end_op = ender;
11181                 if (RExC_close_parens) {
11182                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11183                         "%*s%*s Setting close paren #0 (END) to %d\n",
11184                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11185
11186                     RExC_close_parens[0]= ender;
11187                 }
11188             }
11189             break;
11190         }
11191         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11192             DEBUG_PARSE_MSG("lsbr");
11193             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11194             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11195             Perl_re_printf( aTHX_  "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
11196                           SvPV_nolen_const(RExC_mysv1),
11197                           (IV)REG_NODE_NUM(lastbr),
11198                           SvPV_nolen_const(RExC_mysv2),
11199                           (IV)REG_NODE_NUM(ender),
11200                           (IV)(ender - lastbr)
11201             );
11202         });
11203         REGTAIL(pRExC_state, lastbr, ender);
11204
11205         if (have_branch && !SIZE_ONLY) {
11206             char is_nothing= 1;
11207             if (depth==1)
11208                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11209
11210             /* Hook the tails of the branches to the closing node. */
11211             for (br = ret; br; br = regnext(br)) {
11212                 const U8 op = PL_regkind[OP(br)];
11213                 if (op == BRANCH) {
11214                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11215                     if ( OP(NEXTOPER(br)) != NOTHING
11216                          || regnext(NEXTOPER(br)) != ender)
11217                         is_nothing= 0;
11218                 }
11219                 else if (op == BRANCHJ) {
11220                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11221                     /* for now we always disable this optimisation * /
11222                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11223                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11224                     */
11225                         is_nothing= 0;
11226                 }
11227             }
11228             if (is_nothing) {
11229                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11230                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11231                     DEBUG_PARSE_MSG("NADA");
11232                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11233                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11234                     Perl_re_printf( aTHX_  "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
11235                                   SvPV_nolen_const(RExC_mysv1),
11236                                   (IV)REG_NODE_NUM(ret),
11237                                   SvPV_nolen_const(RExC_mysv2),
11238                                   (IV)REG_NODE_NUM(ender),
11239                                   (IV)(ender - ret)
11240                     );
11241                 });
11242                 OP(br)= NOTHING;
11243                 if (OP(ender) == TAIL) {
11244                     NEXT_OFF(br)= 0;
11245                     RExC_emit= br + 1;
11246                 } else {
11247                     regnode *opt;
11248                     for ( opt= br + 1; opt < ender ; opt++ )
11249                         OP(opt)= OPTIMIZED;
11250                     NEXT_OFF(br)= ender - br;
11251                 }
11252             }
11253         }
11254     }
11255
11256     {
11257         const char *p;
11258         static const char parens[] = "=!<,>";
11259
11260         if (paren && (p = strchr(parens, paren))) {
11261             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11262             int flag = (p - parens) > 1;
11263
11264             if (paren == '>')
11265                 node = SUSPEND, flag = 0;
11266             reginsert(pRExC_state, node,ret, depth+1);
11267             Set_Node_Cur_Length(ret, parse_start);
11268             Set_Node_Offset(ret, parse_start + 1);
11269             ret->flags = flag;
11270             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11271         }
11272     }
11273
11274     /* Check for proper termination. */
11275     if (paren) {
11276         /* restore original flags, but keep (?p) and, if we've changed from /d
11277          * rules to /u, keep the /u */
11278         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11279         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11280             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11281         }
11282         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11283             RExC_parse = oregcomp_parse;
11284             vFAIL("Unmatched (");
11285         }
11286         nextchar(pRExC_state);
11287     }
11288     else if (!paren && RExC_parse < RExC_end) {
11289         if (*RExC_parse == ')') {
11290             RExC_parse++;
11291             vFAIL("Unmatched )");
11292         }
11293         else
11294             FAIL("Junk on end of regexp");      /* "Can't happen". */
11295         NOT_REACHED; /* NOTREACHED */
11296     }
11297
11298     if (RExC_in_lookbehind) {
11299         RExC_in_lookbehind--;
11300     }
11301     if (after_freeze > RExC_npar)
11302         RExC_npar = after_freeze;
11303     return(ret);
11304 }
11305
11306 /*
11307  - regbranch - one alternative of an | operator
11308  *
11309  * Implements the concatenation operator.
11310  *
11311  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11312  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11313  */
11314 STATIC regnode *
11315 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11316 {
11317     regnode *ret;
11318     regnode *chain = NULL;
11319     regnode *latest;
11320     I32 flags = 0, c = 0;
11321     GET_RE_DEBUG_FLAGS_DECL;
11322
11323     PERL_ARGS_ASSERT_REGBRANCH;
11324
11325     DEBUG_PARSE("brnc");
11326
11327     if (first)
11328         ret = NULL;
11329     else {
11330         if (!SIZE_ONLY && RExC_extralen)
11331             ret = reganode(pRExC_state, BRANCHJ,0);
11332         else {
11333             ret = reg_node(pRExC_state, BRANCH);
11334             Set_Node_Length(ret, 1);
11335         }
11336     }
11337
11338     if (!first && SIZE_ONLY)
11339         RExC_extralen += 1;                     /* BRANCHJ */
11340
11341     *flagp = WORST;                     /* Tentatively. */
11342
11343     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11344                             FALSE /* Don't force to /x */ );
11345     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11346         flags &= ~TRYAGAIN;
11347         latest = regpiece(pRExC_state, &flags,depth+1);
11348         if (latest == NULL) {
11349             if (flags & TRYAGAIN)
11350                 continue;
11351             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11352                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11353                 return NULL;
11354             }
11355             FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags);
11356         }
11357         else if (ret == NULL)
11358             ret = latest;
11359         *flagp |= flags&(HASWIDTH|POSTPONED);
11360         if (chain == NULL)      /* First piece. */
11361             *flagp |= flags&SPSTART;
11362         else {
11363             /* FIXME adding one for every branch after the first is probably
11364              * excessive now we have TRIE support. (hv) */
11365             MARK_NAUGHTY(1);
11366             REGTAIL(pRExC_state, chain, latest);
11367         }
11368         chain = latest;
11369         c++;
11370     }
11371     if (chain == NULL) {        /* Loop ran zero times. */
11372         chain = reg_node(pRExC_state, NOTHING);
11373         if (ret == NULL)
11374             ret = chain;
11375     }
11376     if (c == 1) {
11377         *flagp |= flags&SIMPLE;
11378     }
11379
11380     return ret;
11381 }
11382
11383 /*
11384  - regpiece - something followed by possible [*+?]
11385  *
11386  * Note that the branching code sequences used for ? and the general cases
11387  * of * and + are somewhat optimized:  they use the same NOTHING node as
11388  * both the endmarker for their branch list and the body of the last branch.
11389  * It might seem that this node could be dispensed with entirely, but the
11390  * endmarker role is not redundant.
11391  *
11392  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11393  * TRYAGAIN.
11394  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11395  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11396  */
11397 STATIC regnode *
11398 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11399 {
11400     regnode *ret;
11401     char op;
11402     char *next;
11403     I32 flags;
11404     const char * const origparse = RExC_parse;
11405     I32 min;
11406     I32 max = REG_INFTY;
11407 #ifdef RE_TRACK_PATTERN_OFFSETS
11408     char *parse_start;
11409 #endif
11410     const char *maxpos = NULL;
11411     UV uv;
11412
11413     /* Save the original in case we change the emitted regop to a FAIL. */
11414     regnode * const orig_emit = RExC_emit;
11415
11416     GET_RE_DEBUG_FLAGS_DECL;
11417
11418     PERL_ARGS_ASSERT_REGPIECE;
11419
11420     DEBUG_PARSE("piec");
11421
11422     ret = regatom(pRExC_state, &flags,depth+1);
11423     if (ret == NULL) {
11424         if (flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8))
11425             *flagp |= flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8);
11426         else
11427             FAIL2("panic: regatom returned NULL, flags=%#"UVxf"", (UV) flags);
11428         return(NULL);
11429     }
11430
11431     op = *RExC_parse;
11432
11433     if (op == '{' && regcurly(RExC_parse)) {
11434         maxpos = NULL;
11435 #ifdef RE_TRACK_PATTERN_OFFSETS
11436         parse_start = RExC_parse; /* MJD */
11437 #endif
11438         next = RExC_parse + 1;
11439         while (isDIGIT(*next) || *next == ',') {
11440             if (*next == ',') {
11441                 if (maxpos)
11442                     break;
11443                 else
11444                     maxpos = next;
11445             }
11446             next++;
11447         }
11448         if (*next == '}') {             /* got one */
11449             const char* endptr;
11450             if (!maxpos)
11451                 maxpos = next;
11452             RExC_parse++;
11453             if (isDIGIT(*RExC_parse)) {
11454                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
11455                     vFAIL("Invalid quantifier in {,}");
11456                 if (uv >= REG_INFTY)
11457                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11458                 min = (I32)uv;
11459             } else {
11460                 min = 0;
11461             }
11462             if (*maxpos == ',')
11463                 maxpos++;
11464             else
11465                 maxpos = RExC_parse;
11466             if (isDIGIT(*maxpos)) {
11467                 if (!grok_atoUV(maxpos, &uv, &endptr))
11468                     vFAIL("Invalid quantifier in {,}");
11469                 if (uv >= REG_INFTY)
11470                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11471                 max = (I32)uv;
11472             } else {
11473                 max = REG_INFTY;                /* meaning "infinity" */
11474             }
11475             RExC_parse = next;
11476             nextchar(pRExC_state);
11477             if (max < min) {    /* If can't match, warn and optimize to fail
11478                                    unconditionally */
11479                 if (SIZE_ONLY) {
11480
11481                     /* We can't back off the size because we have to reserve
11482                      * enough space for all the things we are about to throw
11483                      * away, but we can shrink it by the amount we are about
11484                      * to re-use here */
11485                     RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
11486                 }
11487                 else {
11488                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
11489                     RExC_emit = orig_emit;
11490                 }
11491                 ret = reganode(pRExC_state, OPFAIL, 0);
11492                 return ret;
11493             }
11494             else if (min == max && *RExC_parse == '?')
11495             {
11496                 if (PASS2) {
11497                     ckWARN2reg(RExC_parse + 1,
11498                                "Useless use of greediness modifier '%c'",
11499                                *RExC_parse);
11500                 }
11501             }
11502
11503           do_curly:
11504             if ((flags&SIMPLE)) {
11505                 if (min == 0 && max == REG_INFTY) {
11506                     reginsert(pRExC_state, STAR, ret, depth+1);
11507                     ret->flags = 0;
11508                     MARK_NAUGHTY(4);
11509                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11510                     goto nest_check;
11511                 }
11512                 if (min == 1 && max == REG_INFTY) {
11513                     reginsert(pRExC_state, PLUS, ret, depth+1);
11514                     ret->flags = 0;
11515                     MARK_NAUGHTY(3);
11516                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11517                     goto nest_check;
11518                 }
11519                 MARK_NAUGHTY_EXP(2, 2);
11520                 reginsert(pRExC_state, CURLY, ret, depth+1);
11521                 Set_Node_Offset(ret, parse_start+1); /* MJD */
11522                 Set_Node_Cur_Length(ret, parse_start);
11523             }
11524             else {
11525                 regnode * const w = reg_node(pRExC_state, WHILEM);
11526
11527                 w->flags = 0;
11528                 REGTAIL(pRExC_state, ret, w);
11529                 if (!SIZE_ONLY && RExC_extralen) {
11530                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
11531                     reginsert(pRExC_state, NOTHING,ret, depth+1);
11532                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
11533                 }
11534                 reginsert(pRExC_state, CURLYX,ret, depth+1);
11535                                 /* MJD hk */
11536                 Set_Node_Offset(ret, parse_start+1);
11537                 Set_Node_Length(ret,
11538                                 op == '{' ? (RExC_parse - parse_start) : 1);
11539
11540                 if (!SIZE_ONLY && RExC_extralen)
11541                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
11542                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
11543                 if (SIZE_ONLY)
11544                     RExC_whilem_seen++, RExC_extralen += 3;
11545                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
11546             }
11547             ret->flags = 0;
11548
11549             if (min > 0)
11550                 *flagp = WORST;
11551             if (max > 0)
11552                 *flagp |= HASWIDTH;
11553             if (!SIZE_ONLY) {
11554                 ARG1_SET(ret, (U16)min);
11555                 ARG2_SET(ret, (U16)max);
11556             }
11557             if (max == REG_INFTY)
11558                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11559
11560             goto nest_check;
11561         }
11562     }
11563
11564     if (!ISMULT1(op)) {
11565         *flagp = flags;
11566         return(ret);
11567     }
11568
11569 #if 0                           /* Now runtime fix should be reliable. */
11570
11571     /* if this is reinstated, don't forget to put this back into perldiag:
11572
11573             =item Regexp *+ operand could be empty at {#} in regex m/%s/
11574
11575            (F) The part of the regexp subject to either the * or + quantifier
11576            could match an empty string. The {#} shows in the regular
11577            expression about where the problem was discovered.
11578
11579     */
11580
11581     if (!(flags&HASWIDTH) && op != '?')
11582       vFAIL("Regexp *+ operand could be empty");
11583 #endif
11584
11585 #ifdef RE_TRACK_PATTERN_OFFSETS
11586     parse_start = RExC_parse;
11587 #endif
11588     nextchar(pRExC_state);
11589
11590     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
11591
11592     if (op == '*') {
11593         min = 0;
11594         goto do_curly;
11595     }
11596     else if (op == '+') {
11597         min = 1;
11598         goto do_curly;
11599     }
11600     else if (op == '?') {
11601         min = 0; max = 1;
11602         goto do_curly;
11603     }
11604   nest_check:
11605     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
11606         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11607         ckWARN2reg(RExC_parse,
11608                    "%"UTF8f" matches null string many times",
11609                    UTF8fARG(UTF, (RExC_parse >= origparse
11610                                  ? RExC_parse - origparse
11611                                  : 0),
11612                    origparse));
11613         (void)ReREFCNT_inc(RExC_rx_sv);
11614     }
11615
11616     if (*RExC_parse == '?') {
11617         nextchar(pRExC_state);
11618         reginsert(pRExC_state, MINMOD, ret, depth+1);
11619         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11620     }
11621     else if (*RExC_parse == '+') {
11622         regnode *ender;
11623         nextchar(pRExC_state);
11624         ender = reg_node(pRExC_state, SUCCEED);
11625         REGTAIL(pRExC_state, ret, ender);
11626         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11627         ret->flags = 0;
11628         ender = reg_node(pRExC_state, TAIL);
11629         REGTAIL(pRExC_state, ret, ender);
11630     }
11631
11632     if (ISMULT2(RExC_parse)) {
11633         RExC_parse++;
11634         vFAIL("Nested quantifiers");
11635     }
11636
11637     return(ret);
11638 }
11639
11640 STATIC bool
11641 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11642                 regnode ** node_p,
11643                 UV * code_point_p,
11644                 int * cp_count,
11645                 I32 * flagp,
11646                 const bool strict,
11647                 const U32 depth
11648     )
11649 {
11650  /* This routine teases apart the various meanings of \N and returns
11651   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11652   * in the current context.
11653   *
11654   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11655   *
11656   * If <code_point_p> is not NULL, the context is expecting the result to be a
11657   * single code point.  If this \N instance turns out to a single code point,
11658   * the function returns TRUE and sets *code_point_p to that code point.
11659   *
11660   * If <node_p> is not NULL, the context is expecting the result to be one of
11661   * the things representable by a regnode.  If this \N instance turns out to be
11662   * one such, the function generates the regnode, returns TRUE and sets *node_p
11663   * to point to that regnode.
11664   *
11665   * If this instance of \N isn't legal in any context, this function will
11666   * generate a fatal error and not return.
11667   *
11668   * On input, RExC_parse should point to the first char following the \N at the
11669   * time of the call.  On successful return, RExC_parse will have been updated
11670   * to point to just after the sequence identified by this routine.  Also
11671   * *flagp has been updated as needed.
11672   *
11673   * When there is some problem with the current context and this \N instance,
11674   * the function returns FALSE, without advancing RExC_parse, nor setting
11675   * *node_p, nor *code_point_p, nor *flagp.
11676   *
11677   * If <cp_count> is not NULL, the caller wants to know the length (in code
11678   * points) that this \N sequence matches.  This is set even if the function
11679   * returns FALSE, as detailed below.
11680   *
11681   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11682   *
11683   * Probably the most common case is for the \N to specify a single code point.
11684   * *cp_count will be set to 1, and *code_point_p will be set to that code
11685   * point.
11686   *
11687   * Another possibility is for the input to be an empty \N{}, which for
11688   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11689   * will be set to a generated NOTHING node.
11690   *
11691   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11692   * set to 0. *node_p will be set to a generated REG_ANY node.
11693   *
11694   * The fourth possibility is that \N resolves to a sequence of more than one
11695   * code points.  *cp_count will be set to the number of code points in the
11696   * sequence. *node_p * will be set to a generated node returned by this
11697   * function calling S_reg().
11698   *
11699   * The final possibility is that it is premature to be calling this function;
11700   * that pass1 needs to be restarted.  This can happen when this changes from
11701   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
11702   * latter occurs only when the fourth possibility would otherwise be in
11703   * effect, and is because one of those code points requires the pattern to be
11704   * recompiled as UTF-8.  The function returns FALSE, and sets the
11705   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
11706   * happens, the caller needs to desist from continuing parsing, and return
11707   * this information to its caller.  This is not set for when there is only one
11708   * code point, as this can be called as part of an ANYOF node, and they can
11709   * store above-Latin1 code points without the pattern having to be in UTF-8.
11710   *
11711   * For non-single-quoted regexes, the tokenizer has resolved character and
11712   * sequence names inside \N{...} into their Unicode values, normalizing the
11713   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11714   * hex-represented code points in the sequence.  This is done there because
11715   * the names can vary based on what charnames pragma is in scope at the time,
11716   * so we need a way to take a snapshot of what they resolve to at the time of
11717   * the original parse. [perl #56444].
11718   *
11719   * That parsing is skipped for single-quoted regexes, so we may here get
11720   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11721   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11722   * is legal and handled here.  The code point is Unicode, and has to be
11723   * translated into the native character set for non-ASCII platforms.
11724   */
11725
11726     char * endbrace;    /* points to '}' following the name */
11727     char *endchar;      /* Points to '.' or '}' ending cur char in the input
11728                            stream */
11729     char* p = RExC_parse; /* Temporary */
11730
11731     GET_RE_DEBUG_FLAGS_DECL;
11732
11733     PERL_ARGS_ASSERT_GROK_BSLASH_N;
11734
11735     GET_RE_DEBUG_FLAGS;
11736
11737     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
11738     assert(! (node_p && cp_count));               /* At most 1 should be set */
11739
11740     if (cp_count) {     /* Initialize return for the most common case */
11741         *cp_count = 1;
11742     }
11743
11744     /* The [^\n] meaning of \N ignores spaces and comments under the /x
11745      * modifier.  The other meanings do not, so use a temporary until we find
11746      * out which we are being called with */
11747     skip_to_be_ignored_text(pRExC_state, &p,
11748                             FALSE /* Don't force to /x */ );
11749
11750     /* Disambiguate between \N meaning a named character versus \N meaning
11751      * [^\n].  The latter is assumed when the {...} following the \N is a legal
11752      * quantifier, or there is no '{' at all */
11753     if (*p != '{' || regcurly(p)) {
11754         RExC_parse = p;
11755         if (cp_count) {
11756             *cp_count = -1;
11757         }
11758
11759         if (! node_p) {
11760             return FALSE;
11761         }
11762
11763         *node_p = reg_node(pRExC_state, REG_ANY);
11764         *flagp |= HASWIDTH|SIMPLE;
11765         MARK_NAUGHTY(1);
11766         Set_Node_Length(*node_p, 1); /* MJD */
11767         return TRUE;
11768     }
11769
11770     /* Here, we have decided it should be a named character or sequence */
11771
11772     /* The test above made sure that the next real character is a '{', but
11773      * under the /x modifier, it could be separated by space (or a comment and
11774      * \n) and this is not allowed (for consistency with \x{...} and the
11775      * tokenizer handling of \N{NAME}). */
11776     if (*RExC_parse != '{') {
11777         vFAIL("Missing braces on \\N{}");
11778     }
11779
11780     RExC_parse++;       /* Skip past the '{' */
11781
11782     if (! (endbrace = strchr(RExC_parse, '}'))  /* no trailing brace */
11783         || ! (endbrace == RExC_parse            /* nothing between the {} */
11784               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
11785                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
11786                                                        error msg) */
11787     {
11788         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
11789         vFAIL("\\N{NAME} must be resolved by the lexer");
11790     }
11791
11792     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
11793                                         semantics */
11794
11795     if (endbrace == RExC_parse) {   /* empty: \N{} */
11796         if (strict) {
11797             RExC_parse++;   /* Position after the "}" */
11798             vFAIL("Zero length \\N{}");
11799         }
11800         if (cp_count) {
11801             *cp_count = 0;
11802         }
11803         nextchar(pRExC_state);
11804         if (! node_p) {
11805             return FALSE;
11806         }
11807
11808         *node_p = reg_node(pRExC_state,NOTHING);
11809         return TRUE;
11810     }
11811
11812     RExC_parse += 2;    /* Skip past the 'U+' */
11813
11814     /* Because toke.c has generated a special construct for us guaranteed not
11815      * to have NULs, we can use a str function */
11816     endchar = RExC_parse + strcspn(RExC_parse, ".}");
11817
11818     /* Code points are separated by dots.  If none, there is only one code
11819      * point, and is terminated by the brace */
11820
11821     if (endchar >= endbrace) {
11822         STRLEN length_of_hex;
11823         I32 grok_hex_flags;
11824
11825         /* Here, exactly one code point.  If that isn't what is wanted, fail */
11826         if (! code_point_p) {
11827             RExC_parse = p;
11828             return FALSE;
11829         }
11830
11831         /* Convert code point from hex */
11832         length_of_hex = (STRLEN)(endchar - RExC_parse);
11833         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
11834                            | PERL_SCAN_DISALLOW_PREFIX
11835
11836                              /* No errors in the first pass (See [perl
11837                               * #122671].)  We let the code below find the
11838                               * errors when there are multiple chars. */
11839                            | ((SIZE_ONLY)
11840                               ? PERL_SCAN_SILENT_ILLDIGIT
11841                               : 0);
11842
11843         /* This routine is the one place where both single- and double-quotish
11844          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
11845          * must be converted to native. */
11846         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
11847                                          &length_of_hex,
11848                                          &grok_hex_flags,
11849                                          NULL));
11850
11851         /* The tokenizer should have guaranteed validity, but it's possible to
11852          * bypass it by using single quoting, so check.  Don't do the check
11853          * here when there are multiple chars; we do it below anyway. */
11854         if (length_of_hex == 0
11855             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
11856         {
11857             RExC_parse += length_of_hex;        /* Includes all the valid */
11858             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
11859                             ? UTF8SKIP(RExC_parse)
11860                             : 1;
11861             /* Guard against malformed utf8 */
11862             if (RExC_parse >= endchar) {
11863                 RExC_parse = endchar;
11864             }
11865             vFAIL("Invalid hexadecimal number in \\N{U+...}");
11866         }
11867
11868         RExC_parse = endbrace + 1;
11869         return TRUE;
11870     }
11871     else {  /* Is a multiple character sequence */
11872         SV * substitute_parse;
11873         STRLEN len;
11874         char *orig_end = RExC_end;
11875         char *save_start = RExC_start;
11876         I32 flags;
11877
11878         /* Count the code points, if desired, in the sequence */
11879         if (cp_count) {
11880             *cp_count = 0;
11881             while (RExC_parse < endbrace) {
11882                 /* Point to the beginning of the next character in the sequence. */
11883                 RExC_parse = endchar + 1;
11884                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
11885                 (*cp_count)++;
11886             }
11887         }
11888
11889         /* Fail if caller doesn't want to handle a multi-code-point sequence.
11890          * But don't backup up the pointer if the caller want to know how many
11891          * code points there are (they can then handle things) */
11892         if (! node_p) {
11893             if (! cp_count) {
11894                 RExC_parse = p;
11895             }
11896             return FALSE;
11897         }
11898
11899         /* What is done here is to convert this to a sub-pattern of the form
11900          * \x{char1}\x{char2}...  and then call reg recursively to parse it
11901          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
11902          * while not having to worry about special handling that some code
11903          * points may have. */
11904
11905         substitute_parse = newSVpvs("?:");
11906
11907         while (RExC_parse < endbrace) {
11908
11909             /* Convert to notation the rest of the code understands */
11910             sv_catpv(substitute_parse, "\\x{");
11911             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
11912             sv_catpv(substitute_parse, "}");
11913
11914             /* Point to the beginning of the next character in the sequence. */
11915             RExC_parse = endchar + 1;
11916             endchar = RExC_parse + strcspn(RExC_parse, ".}");
11917
11918         }
11919         sv_catpv(substitute_parse, ")");
11920
11921         RExC_parse = RExC_start = RExC_adjusted_start = SvPV(substitute_parse,
11922                                                              len);
11923
11924         /* Don't allow empty number */
11925         if (len < (STRLEN) 8) {
11926             RExC_parse = endbrace;
11927             vFAIL("Invalid hexadecimal number in \\N{U+...}");
11928         }
11929         RExC_end = RExC_parse + len;
11930
11931         /* The values are Unicode, and therefore not subject to recoding, but
11932          * have to be converted to native on a non-Unicode (meaning non-ASCII)
11933          * platform. */
11934         RExC_override_recoding = 1;
11935 #ifdef EBCDIC
11936         RExC_recode_x_to_native = 1;
11937 #endif
11938
11939         if (node_p) {
11940             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
11941                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
11942                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11943                     return FALSE;
11944                 }
11945                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
11946                     (UV) flags);
11947             }
11948             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
11949         }
11950
11951         /* Restore the saved values */
11952         RExC_start = RExC_adjusted_start = save_start;
11953         RExC_parse = endbrace;
11954         RExC_end = orig_end;
11955         RExC_override_recoding = 0;
11956 #ifdef EBCDIC
11957         RExC_recode_x_to_native = 0;
11958 #endif
11959
11960         SvREFCNT_dec_NN(substitute_parse);
11961         nextchar(pRExC_state);
11962
11963         return TRUE;
11964     }
11965 }
11966
11967
11968 /*
11969  * reg_recode
11970  *
11971  * It returns the code point in utf8 for the value in *encp.
11972  *    value: a code value in the source encoding
11973  *    encp:  a pointer to an Encode object
11974  *
11975  * If the result from Encode is not a single character,
11976  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
11977  */
11978 STATIC UV
11979 S_reg_recode(pTHX_ const U8 value, SV **encp)
11980 {
11981     STRLEN numlen = 1;
11982     SV * const sv = newSVpvn_flags((const char *) &value, numlen, SVs_TEMP);
11983     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
11984     const STRLEN newlen = SvCUR(sv);
11985     UV uv = UNICODE_REPLACEMENT;
11986
11987     PERL_ARGS_ASSERT_REG_RECODE;
11988
11989     if (newlen)
11990         uv = SvUTF8(sv)
11991              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
11992              : *(U8*)s;
11993
11994     if (!newlen || numlen != newlen) {
11995         uv = UNICODE_REPLACEMENT;
11996         *encp = NULL;
11997     }
11998     return uv;
11999 }
12000
12001 PERL_STATIC_INLINE U8
12002 S_compute_EXACTish(RExC_state_t *pRExC_state)
12003 {
12004     U8 op;
12005
12006     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12007
12008     if (! FOLD) {
12009         return (LOC)
12010                 ? EXACTL
12011                 : EXACT;
12012     }
12013
12014     op = get_regex_charset(RExC_flags);
12015     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12016         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12017                  been, so there is no hole */
12018     }
12019
12020     return op + EXACTF;
12021 }
12022
12023 PERL_STATIC_INLINE void
12024 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12025                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12026                          bool downgradable)
12027 {
12028     /* This knows the details about sizing an EXACTish node, setting flags for
12029      * it (by setting <*flagp>, and potentially populating it with a single
12030      * character.
12031      *
12032      * If <len> (the length in bytes) is non-zero, this function assumes that
12033      * the node has already been populated, and just does the sizing.  In this
12034      * case <code_point> should be the final code point that has already been
12035      * placed into the node.  This value will be ignored except that under some
12036      * circumstances <*flagp> is set based on it.
12037      *
12038      * If <len> is zero, the function assumes that the node is to contain only
12039      * the single character given by <code_point> and calculates what <len>
12040      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12041      * additionally will populate the node's STRING with <code_point> or its
12042      * fold if folding.
12043      *
12044      * In both cases <*flagp> is appropriately set
12045      *
12046      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12047      * 255, must be folded (the former only when the rules indicate it can
12048      * match 'ss')
12049      *
12050      * When it does the populating, it looks at the flag 'downgradable'.  If
12051      * true with a node that folds, it checks if the single code point
12052      * participates in a fold, and if not downgrades the node to an EXACT.
12053      * This helps the optimizer */
12054
12055     bool len_passed_in = cBOOL(len != 0);
12056     U8 character[UTF8_MAXBYTES_CASE+1];
12057
12058     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12059
12060     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12061      * sizing difference, and is extra work that is thrown away */
12062     if (downgradable && ! PASS2) {
12063         downgradable = FALSE;
12064     }
12065
12066     if (! len_passed_in) {
12067         if (UTF) {
12068             if (UVCHR_IS_INVARIANT(code_point)) {
12069                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12070                     *character = (U8) code_point;
12071                 }
12072                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12073                           ASCII, which isn't the same thing as INVARIANT on
12074                           EBCDIC, but it works there, as the extra invariants
12075                           fold to themselves) */
12076                     *character = toFOLD((U8) code_point);
12077
12078                     /* We can downgrade to an EXACT node if this character
12079                      * isn't a folding one.  Note that this assumes that
12080                      * nothing above Latin1 folds to some other invariant than
12081                      * one of these alphabetics; otherwise we would also have
12082                      * to check:
12083                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12084                      *      || ASCII_FOLD_RESTRICTED))
12085                      */
12086                     if (downgradable && PL_fold[code_point] == code_point) {
12087                         OP(node) = EXACT;
12088                     }
12089                 }
12090                 len = 1;
12091             }
12092             else if (FOLD && (! LOC
12093                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12094             {   /* Folding, and ok to do so now */
12095                 UV folded = _to_uni_fold_flags(
12096                                    code_point,
12097                                    character,
12098                                    &len,
12099                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12100                                                       ? FOLD_FLAGS_NOMIX_ASCII
12101                                                       : 0));
12102                 if (downgradable
12103                     && folded == code_point /* This quickly rules out many
12104                                                cases, avoiding the
12105                                                _invlist_contains_cp() overhead
12106                                                for those.  */
12107                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12108                 {
12109                     OP(node) = (LOC)
12110                                ? EXACTL
12111                                : EXACT;
12112                 }
12113             }
12114             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12115
12116                 /* Not folding this cp, and can output it directly */
12117                 *character = UTF8_TWO_BYTE_HI(code_point);
12118                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12119                 len = 2;
12120             }
12121             else {
12122                 uvchr_to_utf8( character, code_point);
12123                 len = UTF8SKIP(character);
12124             }
12125         } /* Else pattern isn't UTF8.  */
12126         else if (! FOLD) {
12127             *character = (U8) code_point;
12128             len = 1;
12129         } /* Else is folded non-UTF8 */
12130 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12131    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12132                                       || UNICODE_DOT_DOT_VERSION > 0)
12133         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12134 #else
12135         else if (1) {
12136 #endif
12137             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12138              * comments at join_exact()); */
12139             *character = (U8) code_point;
12140             len = 1;
12141
12142             /* Can turn into an EXACT node if we know the fold at compile time,
12143              * and it folds to itself and doesn't particpate in other folds */
12144             if (downgradable
12145                 && ! LOC
12146                 && PL_fold_latin1[code_point] == code_point
12147                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12148                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12149             {
12150                 OP(node) = EXACT;
12151             }
12152         } /* else is Sharp s.  May need to fold it */
12153         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12154             *character = 's';
12155             *(character + 1) = 's';
12156             len = 2;
12157         }
12158         else {
12159             *character = LATIN_SMALL_LETTER_SHARP_S;
12160             len = 1;
12161         }
12162     }
12163
12164     if (SIZE_ONLY) {
12165         RExC_size += STR_SZ(len);
12166     }
12167     else {
12168         RExC_emit += STR_SZ(len);
12169         STR_LEN(node) = len;
12170         if (! len_passed_in) {
12171             Copy((char *) character, STRING(node), len, char);
12172         }
12173     }
12174
12175     *flagp |= HASWIDTH;
12176
12177     /* A single character node is SIMPLE, except for the special-cased SHARP S
12178      * under /di. */
12179     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12180 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12181    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12182                                       || UNICODE_DOT_DOT_VERSION > 0)
12183         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12184             || ! FOLD || ! DEPENDS_SEMANTICS)
12185 #endif
12186     ) {
12187         *flagp |= SIMPLE;
12188     }
12189
12190     /* The OP may not be well defined in PASS1 */
12191     if (PASS2 && OP(node) == EXACTFL) {
12192         RExC_contains_locale = 1;
12193     }
12194 }
12195
12196
12197 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12198  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12199
12200 static I32
12201 S_backref_value(char *p)
12202 {
12203     const char* endptr;
12204     UV val;
12205     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12206         return (I32)val;
12207     return I32_MAX;
12208 }
12209
12210
12211 /*
12212  - regatom - the lowest level
12213
12214    Try to identify anything special at the start of the pattern. If there
12215    is, then handle it as required. This may involve generating a single regop,
12216    such as for an assertion; or it may involve recursing, such as to
12217    handle a () structure.
12218
12219    If the string doesn't start with something special then we gobble up
12220    as much literal text as we can.
12221
12222    Once we have been able to handle whatever type of thing started the
12223    sequence, we return.
12224
12225    Note: we have to be careful with escapes, as they can be both literal
12226    and special, and in the case of \10 and friends, context determines which.
12227
12228    A summary of the code structure is:
12229
12230    switch (first_byte) {
12231         cases for each special:
12232             handle this special;
12233             break;
12234         case '\\':
12235             switch (2nd byte) {
12236                 cases for each unambiguous special:
12237                     handle this special;
12238                     break;
12239                 cases for each ambigous special/literal:
12240                     disambiguate;
12241                     if (special)  handle here
12242                     else goto defchar;
12243                 default: // unambiguously literal:
12244                     goto defchar;
12245             }
12246         default:  // is a literal char
12247             // FALL THROUGH
12248         defchar:
12249             create EXACTish node for literal;
12250             while (more input and node isn't full) {
12251                 switch (input_byte) {
12252                    cases for each special;
12253                        make sure parse pointer is set so that the next call to
12254                            regatom will see this special first
12255                        goto loopdone; // EXACTish node terminated by prev. char
12256                    default:
12257                        append char to EXACTISH node;
12258                 }
12259                 get next input byte;
12260             }
12261         loopdone:
12262    }
12263    return the generated node;
12264
12265    Specifically there are two separate switches for handling
12266    escape sequences, with the one for handling literal escapes requiring
12267    a dummy entry for all of the special escapes that are actually handled
12268    by the other.
12269
12270    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12271    TRYAGAIN.
12272    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12273    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12274    Otherwise does not return NULL.
12275 */
12276
12277 STATIC regnode *
12278 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12279 {
12280     regnode *ret = NULL;
12281     I32 flags = 0;
12282     char *parse_start;
12283     U8 op;
12284     int invert = 0;
12285     U8 arg;
12286
12287     GET_RE_DEBUG_FLAGS_DECL;
12288
12289     *flagp = WORST;             /* Tentatively. */
12290
12291     DEBUG_PARSE("atom");
12292
12293     PERL_ARGS_ASSERT_REGATOM;
12294
12295   tryagain:
12296     parse_start = RExC_parse;
12297     assert(RExC_parse < RExC_end);
12298     switch ((U8)*RExC_parse) {
12299     case '^':
12300         RExC_seen_zerolen++;
12301         nextchar(pRExC_state);
12302         if (RExC_flags & RXf_PMf_MULTILINE)
12303             ret = reg_node(pRExC_state, MBOL);
12304         else
12305             ret = reg_node(pRExC_state, SBOL);
12306         Set_Node_Length(ret, 1); /* MJD */
12307         break;
12308     case '$':
12309         nextchar(pRExC_state);
12310         if (*RExC_parse)
12311             RExC_seen_zerolen++;
12312         if (RExC_flags & RXf_PMf_MULTILINE)
12313             ret = reg_node(pRExC_state, MEOL);
12314         else
12315             ret = reg_node(pRExC_state, SEOL);
12316         Set_Node_Length(ret, 1); /* MJD */
12317         break;
12318     case '.':
12319         nextchar(pRExC_state);
12320         if (RExC_flags & RXf_PMf_SINGLELINE)
12321             ret = reg_node(pRExC_state, SANY);
12322         else
12323             ret = reg_node(pRExC_state, REG_ANY);
12324         *flagp |= HASWIDTH|SIMPLE;
12325         MARK_NAUGHTY(1);
12326         Set_Node_Length(ret, 1); /* MJD */
12327         break;
12328     case '[':
12329     {
12330         char * const oregcomp_parse = ++RExC_parse;
12331         ret = regclass(pRExC_state, flagp,depth+1,
12332                        FALSE, /* means parse the whole char class */
12333                        TRUE, /* allow multi-char folds */
12334                        FALSE, /* don't silence non-portable warnings. */
12335                        (bool) RExC_strict,
12336                        TRUE, /* Allow an optimized regnode result */
12337                        NULL,
12338                        NULL);
12339         if (ret == NULL) {
12340             if (*flagp & (RESTART_PASS1|NEED_UTF8))
12341                 return NULL;
12342             FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
12343                   (UV) *flagp);
12344         }
12345         if (*RExC_parse != ']') {
12346             RExC_parse = oregcomp_parse;
12347             vFAIL("Unmatched [");
12348         }
12349         nextchar(pRExC_state);
12350         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12351         break;
12352     }
12353     case '(':
12354         nextchar(pRExC_state);
12355         ret = reg(pRExC_state, 2, &flags,depth+1);
12356         if (ret == NULL) {
12357                 if (flags & TRYAGAIN) {
12358                     if (RExC_parse >= RExC_end) {
12359                          /* Make parent create an empty node if needed. */
12360                         *flagp |= TRYAGAIN;
12361                         return(NULL);
12362                     }
12363                     goto tryagain;
12364                 }
12365                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12366                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12367                     return NULL;
12368                 }
12369                 FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"",
12370                                                                  (UV) flags);
12371         }
12372         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12373         break;
12374     case '|':
12375     case ')':
12376         if (flags & TRYAGAIN) {
12377             *flagp |= TRYAGAIN;
12378             return NULL;
12379         }
12380         vFAIL("Internal urp");
12381                                 /* Supposed to be caught earlier. */
12382         break;
12383     case '?':
12384     case '+':
12385     case '*':
12386         RExC_parse++;
12387         vFAIL("Quantifier follows nothing");
12388         break;
12389     case '\\':
12390         /* Special Escapes
12391
12392            This switch handles escape sequences that resolve to some kind
12393            of special regop and not to literal text. Escape sequnces that
12394            resolve to literal text are handled below in the switch marked
12395            "Literal Escapes".
12396
12397            Every entry in this switch *must* have a corresponding entry
12398            in the literal escape switch. However, the opposite is not
12399            required, as the default for this switch is to jump to the
12400            literal text handling code.
12401         */
12402         RExC_parse++;
12403         switch ((U8)*RExC_parse) {
12404         /* Special Escapes */
12405         case 'A':
12406             RExC_seen_zerolen++;
12407             ret = reg_node(pRExC_state, SBOL);
12408             /* SBOL is shared with /^/ so we set the flags so we can tell
12409              * /\A/ from /^/ in split. We check ret because first pass we
12410              * have no regop struct to set the flags on. */
12411             if (PASS2)
12412                 ret->flags = 1;
12413             *flagp |= SIMPLE;
12414             goto finish_meta_pat;
12415         case 'G':
12416             ret = reg_node(pRExC_state, GPOS);
12417             RExC_seen |= REG_GPOS_SEEN;
12418             *flagp |= SIMPLE;
12419             goto finish_meta_pat;
12420         case 'K':
12421             RExC_seen_zerolen++;
12422             ret = reg_node(pRExC_state, KEEPS);
12423             *flagp |= SIMPLE;
12424             /* XXX:dmq : disabling in-place substitution seems to
12425              * be necessary here to avoid cases of memory corruption, as
12426              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
12427              */
12428             RExC_seen |= REG_LOOKBEHIND_SEEN;
12429             goto finish_meta_pat;
12430         case 'Z':
12431             ret = reg_node(pRExC_state, SEOL);
12432             *flagp |= SIMPLE;
12433             RExC_seen_zerolen++;                /* Do not optimize RE away */
12434             goto finish_meta_pat;
12435         case 'z':
12436             ret = reg_node(pRExC_state, EOS);
12437             *flagp |= SIMPLE;
12438             RExC_seen_zerolen++;                /* Do not optimize RE away */
12439             goto finish_meta_pat;
12440         case 'C':
12441             vFAIL("\\C no longer supported");
12442         case 'X':
12443             ret = reg_node(pRExC_state, CLUMP);
12444             *flagp |= HASWIDTH;
12445             goto finish_meta_pat;
12446
12447         case 'W':
12448             invert = 1;
12449             /* FALLTHROUGH */
12450         case 'w':
12451             arg = ANYOF_WORDCHAR;
12452             goto join_posix;
12453
12454         case 'B':
12455             invert = 1;
12456             /* FALLTHROUGH */
12457         case 'b':
12458           {
12459             regex_charset charset = get_regex_charset(RExC_flags);
12460
12461             RExC_seen_zerolen++;
12462             RExC_seen |= REG_LOOKBEHIND_SEEN;
12463             op = BOUND + charset;
12464
12465             if (op == BOUNDL) {
12466                 RExC_contains_locale = 1;
12467             }
12468
12469             ret = reg_node(pRExC_state, op);
12470             *flagp |= SIMPLE;
12471             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
12472                 FLAGS(ret) = TRADITIONAL_BOUND;
12473                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
12474                     OP(ret) = BOUNDA;
12475                 }
12476             }
12477             else {
12478                 STRLEN length;
12479                 char name = *RExC_parse;
12480                 char * endbrace;
12481                 RExC_parse += 2;
12482                 endbrace = strchr(RExC_parse, '}');
12483
12484                 if (! endbrace) {
12485                     vFAIL2("Missing right brace on \\%c{}", name);
12486                 }
12487                 /* XXX Need to decide whether to take spaces or not.  Should be
12488                  * consistent with \p{}, but that currently is SPACE, which
12489                  * means vertical too, which seems wrong
12490                  * while (isBLANK(*RExC_parse)) {
12491                     RExC_parse++;
12492                 }*/
12493                 if (endbrace == RExC_parse) {
12494                     RExC_parse++;  /* After the '}' */
12495                     vFAIL2("Empty \\%c{}", name);
12496                 }
12497                 length = endbrace - RExC_parse;
12498                 /*while (isBLANK(*(RExC_parse + length - 1))) {
12499                     length--;
12500                 }*/
12501                 switch (*RExC_parse) {
12502                     case 'g':
12503                         if (length != 1
12504                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
12505                         {
12506                             goto bad_bound_type;
12507                         }
12508                         FLAGS(ret) = GCB_BOUND;
12509                         break;
12510                     case 'l':
12511                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12512                             goto bad_bound_type;
12513                         }
12514                         FLAGS(ret) = LB_BOUND;
12515                         break;
12516                     case 's':
12517                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12518                             goto bad_bound_type;
12519                         }
12520                         FLAGS(ret) = SB_BOUND;
12521                         break;
12522                     case 'w':
12523                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12524                             goto bad_bound_type;
12525                         }
12526                         FLAGS(ret) = WB_BOUND;
12527                         break;
12528                     default:
12529                       bad_bound_type:
12530                         RExC_parse = endbrace;
12531                         vFAIL2utf8f(
12532                             "'%"UTF8f"' is an unknown bound type",
12533                             UTF8fARG(UTF, length, endbrace - length));
12534                         NOT_REACHED; /*NOTREACHED*/
12535                 }
12536                 RExC_parse = endbrace;
12537                 REQUIRE_UNI_RULES(flagp, NULL);
12538
12539                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
12540                     OP(ret) = BOUNDU;
12541                     length += 4;
12542
12543                     /* Don't have to worry about UTF-8, in this message because
12544                      * to get here the contents of the \b must be ASCII */
12545                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
12546                               "Using /u for '%.*s' instead of /%s",
12547                               (unsigned) length,
12548                               endbrace - length + 1,
12549                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
12550                               ? ASCII_RESTRICT_PAT_MODS
12551                               : ASCII_MORE_RESTRICT_PAT_MODS);
12552                 }
12553             }
12554
12555             if (PASS2 && invert) {
12556                 OP(ret) += NBOUND - BOUND;
12557             }
12558             goto finish_meta_pat;
12559           }
12560
12561         case 'D':
12562             invert = 1;
12563             /* FALLTHROUGH */
12564         case 'd':
12565             arg = ANYOF_DIGIT;
12566             if (! DEPENDS_SEMANTICS) {
12567                 goto join_posix;
12568             }
12569
12570             /* \d doesn't have any matches in the upper Latin1 range, hence /d
12571              * is equivalent to /u.  Changing to /u saves some branches at
12572              * runtime */
12573             op = POSIXU;
12574             goto join_posix_op_known;
12575
12576         case 'R':
12577             ret = reg_node(pRExC_state, LNBREAK);
12578             *flagp |= HASWIDTH|SIMPLE;
12579             goto finish_meta_pat;
12580
12581         case 'H':
12582             invert = 1;
12583             /* FALLTHROUGH */
12584         case 'h':
12585             arg = ANYOF_BLANK;
12586             op = POSIXU;
12587             goto join_posix_op_known;
12588
12589         case 'V':
12590             invert = 1;
12591             /* FALLTHROUGH */
12592         case 'v':
12593             arg = ANYOF_VERTWS;
12594             op = POSIXU;
12595             goto join_posix_op_known;
12596
12597         case 'S':
12598             invert = 1;
12599             /* FALLTHROUGH */
12600         case 's':
12601             arg = ANYOF_SPACE;
12602
12603           join_posix:
12604
12605             op = POSIXD + get_regex_charset(RExC_flags);
12606             if (op > POSIXA) {  /* /aa is same as /a */
12607                 op = POSIXA;
12608             }
12609             else if (op == POSIXL) {
12610                 RExC_contains_locale = 1;
12611             }
12612
12613           join_posix_op_known:
12614
12615             if (invert) {
12616                 op += NPOSIXD - POSIXD;
12617             }
12618
12619             ret = reg_node(pRExC_state, op);
12620             if (! SIZE_ONLY) {
12621                 FLAGS(ret) = namedclass_to_classnum(arg);
12622             }
12623
12624             *flagp |= HASWIDTH|SIMPLE;
12625             /* FALLTHROUGH */
12626
12627           finish_meta_pat:
12628             nextchar(pRExC_state);
12629             Set_Node_Length(ret, 2); /* MJD */
12630             break;
12631         case 'p':
12632         case 'P':
12633             RExC_parse--;
12634
12635             ret = regclass(pRExC_state, flagp,depth+1,
12636                            TRUE, /* means just parse this element */
12637                            FALSE, /* don't allow multi-char folds */
12638                            FALSE, /* don't silence non-portable warnings.  It
12639                                      would be a bug if these returned
12640                                      non-portables */
12641                            (bool) RExC_strict,
12642                            TRUE, /* Allow an optimized regnode result */
12643                            NULL,
12644                            NULL);
12645             if (*flagp & RESTART_PASS1)
12646                 return NULL;
12647             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
12648              * multi-char folds are allowed.  */
12649             if (!ret)
12650                 FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
12651                       (UV) *flagp);
12652
12653             RExC_parse--;
12654
12655             Set_Node_Offset(ret, parse_start);
12656             Set_Node_Cur_Length(ret, parse_start - 2);
12657             nextchar(pRExC_state);
12658             break;
12659         case 'N':
12660             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12661              * \N{...} evaluates to a sequence of more than one code points).
12662              * The function call below returns a regnode, which is our result.
12663              * The parameters cause it to fail if the \N{} evaluates to a
12664              * single code point; we handle those like any other literal.  The
12665              * reason that the multicharacter case is handled here and not as
12666              * part of the EXACtish code is because of quantifiers.  In
12667              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12668              * this way makes that Just Happen. dmq.
12669              * join_exact() will join this up with adjacent EXACTish nodes
12670              * later on, if appropriate. */
12671             ++RExC_parse;
12672             if (grok_bslash_N(pRExC_state,
12673                               &ret,     /* Want a regnode returned */
12674                               NULL,     /* Fail if evaluates to a single code
12675                                            point */
12676                               NULL,     /* Don't need a count of how many code
12677                                            points */
12678                               flagp,
12679                               RExC_strict,
12680                               depth)
12681             ) {
12682                 break;
12683             }
12684
12685             if (*flagp & RESTART_PASS1)
12686                 return NULL;
12687
12688             /* Here, evaluates to a single code point.  Go get that */
12689             RExC_parse = parse_start;
12690             goto defchar;
12691
12692         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12693       parse_named_seq:
12694         {
12695             char ch;
12696             if (   RExC_parse >= RExC_end - 1
12697                 || ((   ch = RExC_parse[1]) != '<'
12698                                       && ch != '\''
12699                                       && ch != '{'))
12700             {
12701                 RExC_parse++;
12702                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12703                 vFAIL2("Sequence %.2s... not terminated",parse_start);
12704             } else {
12705                 RExC_parse += 2;
12706                 ret = handle_named_backref(pRExC_state,
12707                                            flagp,
12708                                            parse_start,
12709                                            (ch == '<')
12710                                            ? '>'
12711                                            : (ch == '{')
12712                                              ? '}'
12713                                              : '\'');
12714             }
12715             break;
12716         }
12717         case 'g':
12718         case '1': case '2': case '3': case '4':
12719         case '5': case '6': case '7': case '8': case '9':
12720             {
12721                 I32 num;
12722                 bool hasbrace = 0;
12723
12724                 if (*RExC_parse == 'g') {
12725                     bool isrel = 0;
12726
12727                     RExC_parse++;
12728                     if (*RExC_parse == '{') {
12729                         RExC_parse++;
12730                         hasbrace = 1;
12731                     }
12732                     if (*RExC_parse == '-') {
12733                         RExC_parse++;
12734                         isrel = 1;
12735                     }
12736                     if (hasbrace && !isDIGIT(*RExC_parse)) {
12737                         if (isrel) RExC_parse--;
12738                         RExC_parse -= 2;
12739                         goto parse_named_seq;
12740                     }
12741
12742                     if (RExC_parse >= RExC_end) {
12743                         goto unterminated_g;
12744                     }
12745                     num = S_backref_value(RExC_parse);
12746                     if (num == 0)
12747                         vFAIL("Reference to invalid group 0");
12748                     else if (num == I32_MAX) {
12749                          if (isDIGIT(*RExC_parse))
12750                             vFAIL("Reference to nonexistent group");
12751                         else
12752                           unterminated_g:
12753                             vFAIL("Unterminated \\g... pattern");
12754                     }
12755
12756                     if (isrel) {
12757                         num = RExC_npar - num;
12758                         if (num < 1)
12759                             vFAIL("Reference to nonexistent or unclosed group");
12760                     }
12761                 }
12762                 else {
12763                     num = S_backref_value(RExC_parse);
12764                     /* bare \NNN might be backref or octal - if it is larger
12765                      * than or equal RExC_npar then it is assumed to be an
12766                      * octal escape. Note RExC_npar is +1 from the actual
12767                      * number of parens. */
12768                     /* Note we do NOT check if num == I32_MAX here, as that is
12769                      * handled by the RExC_npar check */
12770
12771                     if (
12772                         /* any numeric escape < 10 is always a backref */
12773                         num > 9
12774                         /* any numeric escape < RExC_npar is a backref */
12775                         && num >= RExC_npar
12776                         /* cannot be an octal escape if it starts with 8 */
12777                         && *RExC_parse != '8'
12778                         /* cannot be an octal escape it it starts with 9 */
12779                         && *RExC_parse != '9'
12780                     )
12781                     {
12782                         /* Probably not a backref, instead likely to be an
12783                          * octal character escape, e.g. \35 or \777.
12784                          * The above logic should make it obvious why using
12785                          * octal escapes in patterns is problematic. - Yves */
12786                         RExC_parse = parse_start;
12787                         goto defchar;
12788                     }
12789                 }
12790
12791                 /* At this point RExC_parse points at a numeric escape like
12792                  * \12 or \88 or something similar, which we should NOT treat
12793                  * as an octal escape. It may or may not be a valid backref
12794                  * escape. For instance \88888888 is unlikely to be a valid
12795                  * backref. */
12796                 while (isDIGIT(*RExC_parse))
12797                     RExC_parse++;
12798                 if (hasbrace) {
12799                     if (*RExC_parse != '}')
12800                         vFAIL("Unterminated \\g{...} pattern");
12801                     RExC_parse++;
12802                 }
12803                 if (!SIZE_ONLY) {
12804                     if (num > (I32)RExC_rx->nparens)
12805                         vFAIL("Reference to nonexistent group");
12806                 }
12807                 RExC_sawback = 1;
12808                 ret = reganode(pRExC_state,
12809                                ((! FOLD)
12810                                  ? REF
12811                                  : (ASCII_FOLD_RESTRICTED)
12812                                    ? REFFA
12813                                    : (AT_LEAST_UNI_SEMANTICS)
12814                                      ? REFFU
12815                                      : (LOC)
12816                                        ? REFFL
12817                                        : REFF),
12818                                 num);
12819                 *flagp |= HASWIDTH;
12820
12821                 /* override incorrect value set in reganode MJD */
12822                 Set_Node_Offset(ret, parse_start);
12823                 Set_Node_Cur_Length(ret, parse_start-1);
12824                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
12825                                         FALSE /* Don't force to /x */ );
12826             }
12827             break;
12828         case '\0':
12829             if (RExC_parse >= RExC_end)
12830                 FAIL("Trailing \\");
12831             /* FALLTHROUGH */
12832         default:
12833             /* Do not generate "unrecognized" warnings here, we fall
12834                back into the quick-grab loop below */
12835             RExC_parse = parse_start;
12836             goto defchar;
12837         } /* end of switch on a \foo sequence */
12838         break;
12839
12840     case '#':
12841
12842         /* '#' comments should have been spaced over before this function was
12843          * called */
12844         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
12845         /*
12846         if (RExC_flags & RXf_PMf_EXTENDED) {
12847             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
12848             if (RExC_parse < RExC_end)
12849                 goto tryagain;
12850         }
12851         */
12852
12853         /* FALLTHROUGH */
12854
12855     default:
12856           defchar: {
12857
12858             /* Here, we have determined that the next thing is probably a
12859              * literal character.  RExC_parse points to the first byte of its
12860              * definition.  (It still may be an escape sequence that evaluates
12861              * to a single character) */
12862
12863             STRLEN len = 0;
12864             UV ender = 0;
12865             char *p;
12866             char *s;
12867 #define MAX_NODE_STRING_SIZE 127
12868             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
12869             char *s0;
12870             U8 upper_parse = MAX_NODE_STRING_SIZE;
12871             U8 node_type = compute_EXACTish(pRExC_state);
12872             bool next_is_quantifier;
12873             char * oldp = NULL;
12874
12875             /* We can convert EXACTF nodes to EXACTFU if they contain only
12876              * characters that match identically regardless of the target
12877              * string's UTF8ness.  The reason to do this is that EXACTF is not
12878              * trie-able, EXACTFU is.
12879              *
12880              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
12881              * contain only above-Latin1 characters (hence must be in UTF8),
12882              * which don't participate in folds with Latin1-range characters,
12883              * as the latter's folds aren't known until runtime.  (We don't
12884              * need to figure this out until pass 2) */
12885             bool maybe_exactfu = PASS2
12886                                && (node_type == EXACTF || node_type == EXACTFL);
12887
12888             /* If a folding node contains only code points that don't
12889              * participate in folds, it can be changed into an EXACT node,
12890              * which allows the optimizer more things to look for */
12891             bool maybe_exact;
12892
12893             ret = reg_node(pRExC_state, node_type);
12894
12895             /* In pass1, folded, we use a temporary buffer instead of the
12896              * actual node, as the node doesn't exist yet */
12897             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
12898
12899             s0 = s;
12900
12901           reparse:
12902
12903             /* We look for the EXACTFish to EXACT node optimizaton only if
12904              * folding.  (And we don't need to figure this out until pass 2).
12905              * XXX It might actually make sense to split the node into portions
12906              * that are exact and ones that aren't, so that we could later use
12907              * the exact ones to find the longest fixed and floating strings.
12908              * One would want to join them back into a larger node.  One could
12909              * use a pseudo regnode like 'EXACT_ORIG_FOLD' */
12910             maybe_exact = FOLD && PASS2;
12911
12912             /* XXX The node can hold up to 255 bytes, yet this only goes to
12913              * 127.  I (khw) do not know why.  Keeping it somewhat less than
12914              * 255 allows us to not have to worry about overflow due to
12915              * converting to utf8 and fold expansion, but that value is
12916              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
12917              * split up by this limit into a single one using the real max of
12918              * 255.  Even at 127, this breaks under rare circumstances.  If
12919              * folding, we do not want to split a node at a character that is a
12920              * non-final in a multi-char fold, as an input string could just
12921              * happen to want to match across the node boundary.  The join
12922              * would solve that problem if the join actually happens.  But a
12923              * series of more than two nodes in a row each of 127 would cause
12924              * the first join to succeed to get to 254, but then there wouldn't
12925              * be room for the next one, which could at be one of those split
12926              * multi-char folds.  I don't know of any fool-proof solution.  One
12927              * could back off to end with only a code point that isn't such a
12928              * non-final, but it is possible for there not to be any in the
12929              * entire node. */
12930
12931             assert(   ! UTF     /* Is at the beginning of a character */
12932                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
12933                    || UTF8_IS_START(UCHARAT(RExC_parse)));
12934
12935             for (p = RExC_parse;
12936                  len < upper_parse && p < RExC_end;
12937                  len++)
12938             {
12939                 oldp = p;
12940
12941                 /* White space has already been ignored */
12942                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
12943                        || ! is_PATWS_safe((p), RExC_end, UTF));
12944
12945                 switch ((U8)*p) {
12946                 case '^':
12947                 case '$':
12948                 case '.':
12949                 case '[':
12950                 case '(':
12951                 case ')':
12952                 case '|':
12953                     goto loopdone;
12954                 case '\\':
12955                     /* Literal Escapes Switch
12956
12957                        This switch is meant to handle escape sequences that
12958                        resolve to a literal character.
12959
12960                        Every escape sequence that represents something
12961                        else, like an assertion or a char class, is handled
12962                        in the switch marked 'Special Escapes' above in this
12963                        routine, but also has an entry here as anything that
12964                        isn't explicitly mentioned here will be treated as
12965                        an unescaped equivalent literal.
12966                     */
12967
12968                     switch ((U8)*++p) {
12969                     /* These are all the special escapes. */
12970                     case 'A':             /* Start assertion */
12971                     case 'b': case 'B':   /* Word-boundary assertion*/
12972                     case 'C':             /* Single char !DANGEROUS! */
12973                     case 'd': case 'D':   /* digit class */
12974                     case 'g': case 'G':   /* generic-backref, pos assertion */
12975                     case 'h': case 'H':   /* HORIZWS */
12976                     case 'k': case 'K':   /* named backref, keep marker */
12977                     case 'p': case 'P':   /* Unicode property */
12978                               case 'R':   /* LNBREAK */
12979                     case 's': case 'S':   /* space class */
12980                     case 'v': case 'V':   /* VERTWS */
12981                     case 'w': case 'W':   /* word class */
12982                     case 'X':             /* eXtended Unicode "combining
12983                                              character sequence" */
12984                     case 'z': case 'Z':   /* End of line/string assertion */
12985                         --p;
12986                         goto loopdone;
12987
12988                     /* Anything after here is an escape that resolves to a
12989                        literal. (Except digits, which may or may not)
12990                      */
12991                     case 'n':
12992                         ender = '\n';
12993                         p++;
12994                         break;
12995                     case 'N': /* Handle a single-code point named character. */
12996                         RExC_parse = p + 1;
12997                         if (! grok_bslash_N(pRExC_state,
12998                                             NULL,   /* Fail if evaluates to
12999                                                        anything other than a
13000                                                        single code point */
13001                                             &ender, /* The returned single code
13002                                                        point */
13003                                             NULL,   /* Don't need a count of
13004                                                        how many code points */
13005                                             flagp,
13006                                             RExC_strict,
13007                                             depth)
13008                         ) {
13009                             if (*flagp & NEED_UTF8)
13010                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13011                             if (*flagp & RESTART_PASS1)
13012                                 return NULL;
13013
13014                             /* Here, it wasn't a single code point.  Go close
13015                              * up this EXACTish node.  The switch() prior to
13016                              * this switch handles the other cases */
13017                             RExC_parse = p = oldp;
13018                             goto loopdone;
13019                         }
13020                         p = RExC_parse;
13021                         if (ender > 0xff) {
13022                             REQUIRE_UTF8(flagp);
13023                         }
13024                         break;
13025                     case 'r':
13026                         ender = '\r';
13027                         p++;
13028                         break;
13029                     case 't':
13030                         ender = '\t';
13031                         p++;
13032                         break;
13033                     case 'f':
13034                         ender = '\f';
13035                         p++;
13036                         break;
13037                     case 'e':
13038                         ender = ESC_NATIVE;
13039                         p++;
13040                         break;
13041                     case 'a':
13042                         ender = '\a';
13043                         p++;
13044                         break;
13045                     case 'o':
13046                         {
13047                             UV result;
13048                             const char* error_msg;
13049
13050                             bool valid = grok_bslash_o(&p,
13051                                                        &result,
13052                                                        &error_msg,
13053                                                        PASS2, /* out warnings */
13054                                                        (bool) RExC_strict,
13055                                                        TRUE, /* Output warnings
13056                                                                 for non-
13057                                                                 portables */
13058                                                        UTF);
13059                             if (! valid) {
13060                                 RExC_parse = p; /* going to die anyway; point
13061                                                    to exact spot of failure */
13062                                 vFAIL(error_msg);
13063                             }
13064                             ender = result;
13065                             if (IN_ENCODING && ender < 0x100) {
13066                                 goto recode_encoding;
13067                             }
13068                             if (ender > 0xff) {
13069                                 REQUIRE_UTF8(flagp);
13070                             }
13071                             break;
13072                         }
13073                     case 'x':
13074                         {
13075                             UV result = UV_MAX; /* initialize to erroneous
13076                                                    value */
13077                             const char* error_msg;
13078
13079                             bool valid = grok_bslash_x(&p,
13080                                                        &result,
13081                                                        &error_msg,
13082                                                        PASS2, /* out warnings */
13083                                                        (bool) RExC_strict,
13084                                                        TRUE, /* Silence warnings
13085                                                                 for non-
13086                                                                 portables */
13087                                                        UTF);
13088                             if (! valid) {
13089                                 RExC_parse = p; /* going to die anyway; point
13090                                                    to exact spot of failure */
13091                                 vFAIL(error_msg);
13092                             }
13093                             ender = result;
13094
13095                             if (ender < 0x100) {
13096 #ifdef EBCDIC
13097                                 if (RExC_recode_x_to_native) {
13098                                     ender = LATIN1_TO_NATIVE(ender);
13099                                 }
13100                                 else
13101 #endif
13102                                 if (IN_ENCODING) {
13103                                     goto recode_encoding;
13104                                 }
13105                             }
13106                             else {
13107                                 REQUIRE_UTF8(flagp);
13108                             }
13109                             break;
13110                         }
13111                     case 'c':
13112                         p++;
13113                         ender = grok_bslash_c(*p++, PASS2);
13114                         break;
13115                     case '8': case '9': /* must be a backreference */
13116                         --p;
13117                         /* we have an escape like \8 which cannot be an octal escape
13118                          * so we exit the loop, and let the outer loop handle this
13119                          * escape which may or may not be a legitimate backref. */
13120                         goto loopdone;
13121                     case '1': case '2': case '3':case '4':
13122                     case '5': case '6': case '7':
13123                         /* When we parse backslash escapes there is ambiguity
13124                          * between backreferences and octal escapes. Any escape
13125                          * from \1 - \9 is a backreference, any multi-digit
13126                          * escape which does not start with 0 and which when
13127                          * evaluated as decimal could refer to an already
13128                          * parsed capture buffer is a back reference. Anything
13129                          * else is octal.
13130                          *
13131                          * Note this implies that \118 could be interpreted as
13132                          * 118 OR as "\11" . "8" depending on whether there
13133                          * were 118 capture buffers defined already in the
13134                          * pattern.  */
13135
13136                         /* NOTE, RExC_npar is 1 more than the actual number of
13137                          * parens we have seen so far, hence the < RExC_npar below. */
13138
13139                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13140                         {  /* Not to be treated as an octal constant, go
13141                                    find backref */
13142                             --p;
13143                             goto loopdone;
13144                         }
13145                         /* FALLTHROUGH */
13146                     case '0':
13147                         {
13148                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13149                             STRLEN numlen = 3;
13150                             ender = grok_oct(p, &numlen, &flags, NULL);
13151                             if (ender > 0xff) {
13152                                 REQUIRE_UTF8(flagp);
13153                             }
13154                             p += numlen;
13155                             if (PASS2   /* like \08, \178 */
13156                                 && numlen < 3
13157                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13158                             {
13159                                 reg_warn_non_literal_string(
13160                                          p + 1,
13161                                          form_short_octal_warning(p, numlen));
13162                             }
13163                         }
13164                         if (IN_ENCODING && ender < 0x100)
13165                             goto recode_encoding;
13166                         break;
13167                       recode_encoding:
13168                         if (! RExC_override_recoding) {
13169                             SV* enc = _get_encoding();
13170                             ender = reg_recode((U8)ender, &enc);
13171                             if (!enc && PASS2)
13172                                 ckWARNreg(p, "Invalid escape in the specified encoding");
13173                             REQUIRE_UTF8(flagp);
13174                         }
13175                         break;
13176                     case '\0':
13177                         if (p >= RExC_end)
13178                             FAIL("Trailing \\");
13179                         /* FALLTHROUGH */
13180                     default:
13181                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13182                             /* Include any left brace following the alpha to emphasize
13183                              * that it could be part of an escape at some point
13184                              * in the future */
13185                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13186                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13187                         }
13188                         goto normal_default;
13189                     } /* End of switch on '\' */
13190                     break;
13191                 case '{':
13192                     /* Currently we don't warn when the lbrace is at the start
13193                      * of a construct.  This catches it in the middle of a
13194                      * literal string, or when it's the first thing after
13195                      * something like "\b" */
13196                     if (! SIZE_ONLY
13197                         && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
13198                     {
13199                         ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
13200                     }
13201                     /*FALLTHROUGH*/
13202                 default:    /* A literal character */
13203                   normal_default:
13204                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13205                         STRLEN numlen;
13206                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13207                                                &numlen, UTF8_ALLOW_DEFAULT);
13208                         p += numlen;
13209                     }
13210                     else
13211                         ender = (U8) *p++;
13212                     break;
13213                 } /* End of switch on the literal */
13214
13215                 /* Here, have looked at the literal character and <ender>
13216                  * contains its ordinal, <p> points to the character after it.
13217                  * We need to check if the next non-ignored thing is a
13218                  * quantifier.  Move <p> to after anything that should be
13219                  * ignored, which, as a side effect, positions <p> for the next
13220                  * loop iteration */
13221                 skip_to_be_ignored_text(pRExC_state, &p,
13222                                         FALSE /* Don't force to /x */ );
13223
13224                 /* If the next thing is a quantifier, it applies to this
13225                  * character only, which means that this character has to be in
13226                  * its own node and can't just be appended to the string in an
13227                  * existing node, so if there are already other characters in
13228                  * the node, close the node with just them, and set up to do
13229                  * this character again next time through, when it will be the
13230                  * only thing in its new node */
13231                 if ((next_is_quantifier = (   LIKELY(p < RExC_end)
13232                                            && UNLIKELY(ISMULT2(p))))
13233                     && LIKELY(len))
13234                 {
13235                     p = oldp;
13236                     goto loopdone;
13237                 }
13238
13239                 /* Ready to add 'ender' to the node */
13240
13241                 if (! FOLD) {  /* The simple case, just append the literal */
13242
13243                     /* In the sizing pass, we need only the size of the
13244                      * character we are appending, hence we can delay getting
13245                      * its representation until PASS2. */
13246                     if (SIZE_ONLY) {
13247                         if (UTF) {
13248                             const STRLEN unilen = UVCHR_SKIP(ender);
13249                             s += unilen;
13250
13251                             /* We have to subtract 1 just below (and again in
13252                              * the corresponding PASS2 code) because the loop
13253                              * increments <len> each time, as all but this path
13254                              * (and one other) through it add a single byte to
13255                              * the EXACTish node.  But these paths would change
13256                              * len to be the correct final value, so cancel out
13257                              * the increment that follows */
13258                             len += unilen - 1;
13259                         }
13260                         else {
13261                             s++;
13262                         }
13263                     } else { /* PASS2 */
13264                       not_fold_common:
13265                         if (UTF) {
13266                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13267                             len += (char *) new_s - s - 1;
13268                             s = (char *) new_s;
13269                         }
13270                         else {
13271                             *(s++) = (char) ender;
13272                         }
13273                     }
13274                 }
13275                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13276
13277                     /* Here are folding under /l, and the code point is
13278                      * problematic.  First, we know we can't simplify things */
13279                     maybe_exact = FALSE;
13280                     maybe_exactfu = FALSE;
13281
13282                     /* A problematic code point in this context means that its
13283                      * fold isn't known until runtime, so we can't fold it now.
13284                      * (The non-problematic code points are the above-Latin1
13285                      * ones that fold to also all above-Latin1.  Their folds
13286                      * don't vary no matter what the locale is.) But here we
13287                      * have characters whose fold depends on the locale.
13288                      * Unlike the non-folding case above, we have to keep track
13289                      * of these in the sizing pass, so that we can make sure we
13290                      * don't split too-long nodes in the middle of a potential
13291                      * multi-char fold.  And unlike the regular fold case
13292                      * handled in the else clauses below, we don't actually
13293                      * fold and don't have special cases to consider.  What we
13294                      * do for both passes is the PASS2 code for non-folding */
13295                     goto not_fold_common;
13296                 }
13297                 else /* A regular FOLD code point */
13298                     if (! (   UTF
13299 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13300    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13301                                       || UNICODE_DOT_DOT_VERSION > 0)
13302                             /* See comments for join_exact() as to why we fold
13303                              * this non-UTF at compile time */
13304                             || (   node_type == EXACTFU
13305                                 && ender == LATIN_SMALL_LETTER_SHARP_S)
13306 #endif
13307                 )) {
13308                     /* Here, are folding and are not UTF-8 encoded; therefore
13309                      * the character must be in the range 0-255, and is not /l
13310                      * (Not /l because we already handled these under /l in
13311                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13312                     if (IS_IN_SOME_FOLD_L1(ender)) {
13313                         maybe_exact = FALSE;
13314
13315                         /* See if the character's fold differs between /d and
13316                          * /u.  This includes the multi-char fold SHARP S to
13317                          * 'ss' */
13318                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13319                             RExC_seen_unfolded_sharp_s = 1;
13320                             maybe_exactfu = FALSE;
13321                         }
13322                         else if (maybe_exactfu
13323                             && (PL_fold[ender] != PL_fold_latin1[ender]
13324 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13325    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13326                                       || UNICODE_DOT_DOT_VERSION > 0)
13327                                 || (   len > 0
13328                                     && isALPHA_FOLD_EQ(ender, 's')
13329                                     && isALPHA_FOLD_EQ(*(s-1), 's'))
13330 #endif
13331                         )) {
13332                             maybe_exactfu = FALSE;
13333                         }
13334                     }
13335
13336                     /* Even when folding, we store just the input character, as
13337                      * we have an array that finds its fold quickly */
13338                     *(s++) = (char) ender;
13339                 }
13340                 else {  /* FOLD, and UTF (or sharp s) */
13341                     /* Unlike the non-fold case, we do actually have to
13342                      * calculate the results here in pass 1.  This is for two
13343                      * reasons, the folded length may be longer than the
13344                      * unfolded, and we have to calculate how many EXACTish
13345                      * nodes it will take; and we may run out of room in a node
13346                      * in the middle of a potential multi-char fold, and have
13347                      * to back off accordingly.  */
13348
13349                     UV folded;
13350                     if (isASCII_uni(ender)) {
13351                         folded = toFOLD(ender);
13352                         *(s)++ = (U8) folded;
13353                     }
13354                     else {
13355                         STRLEN foldlen;
13356
13357                         folded = _to_uni_fold_flags(
13358                                      ender,
13359                                      (U8 *) s,
13360                                      &foldlen,
13361                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
13362                                                         ? FOLD_FLAGS_NOMIX_ASCII
13363                                                         : 0));
13364                         s += foldlen;
13365
13366                         /* The loop increments <len> each time, as all but this
13367                          * path (and one other) through it add a single byte to
13368                          * the EXACTish node.  But this one has changed len to
13369                          * be the correct final value, so subtract one to
13370                          * cancel out the increment that follows */
13371                         len += foldlen - 1;
13372                     }
13373                     /* If this node only contains non-folding code points so
13374                      * far, see if this new one is also non-folding */
13375                     if (maybe_exact) {
13376                         if (folded != ender) {
13377                             maybe_exact = FALSE;
13378                         }
13379                         else {
13380                             /* Here the fold is the original; we have to check
13381                              * further to see if anything folds to it */
13382                             if (_invlist_contains_cp(PL_utf8_foldable,
13383                                                         ender))
13384                             {
13385                                 maybe_exact = FALSE;
13386                             }
13387                         }
13388                     }
13389                     ender = folded;
13390                 }
13391
13392                 if (next_is_quantifier) {
13393
13394                     /* Here, the next input is a quantifier, and to get here,
13395                      * the current character is the only one in the node.
13396                      * Also, here <len> doesn't include the final byte for this
13397                      * character */
13398                     len++;
13399                     goto loopdone;
13400                 }
13401
13402             } /* End of loop through literal characters */
13403
13404             /* Here we have either exhausted the input or ran out of room in
13405              * the node.  (If we encountered a character that can't be in the
13406              * node, transfer is made directly to <loopdone>, and so we
13407              * wouldn't have fallen off the end of the loop.)  In the latter
13408              * case, we artificially have to split the node into two, because
13409              * we just don't have enough space to hold everything.  This
13410              * creates a problem if the final character participates in a
13411              * multi-character fold in the non-final position, as a match that
13412              * should have occurred won't, due to the way nodes are matched,
13413              * and our artificial boundary.  So back off until we find a non-
13414              * problematic character -- one that isn't at the beginning or
13415              * middle of such a fold.  (Either it doesn't participate in any
13416              * folds, or appears only in the final position of all the folds it
13417              * does participate in.)  A better solution with far fewer false
13418              * positives, and that would fill the nodes more completely, would
13419              * be to actually have available all the multi-character folds to
13420              * test against, and to back-off only far enough to be sure that
13421              * this node isn't ending with a partial one.  <upper_parse> is set
13422              * further below (if we need to reparse the node) to include just
13423              * up through that final non-problematic character that this code
13424              * identifies, so when it is set to less than the full node, we can
13425              * skip the rest of this */
13426             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
13427
13428                 const STRLEN full_len = len;
13429
13430                 assert(len >= MAX_NODE_STRING_SIZE);
13431
13432                 /* Here, <s> points to the final byte of the final character.
13433                  * Look backwards through the string until find a non-
13434                  * problematic character */
13435
13436                 if (! UTF) {
13437
13438                     /* This has no multi-char folds to non-UTF characters */
13439                     if (ASCII_FOLD_RESTRICTED) {
13440                         goto loopdone;
13441                     }
13442
13443                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
13444                     len = s - s0 + 1;
13445                 }
13446                 else {
13447                     if (!  PL_NonL1NonFinalFold) {
13448                         PL_NonL1NonFinalFold = _new_invlist_C_array(
13449                                         NonL1_Perl_Non_Final_Folds_invlist);
13450                     }
13451
13452                     /* Point to the first byte of the final character */
13453                     s = (char *) utf8_hop((U8 *) s, -1);
13454
13455                     while (s >= s0) {   /* Search backwards until find
13456                                            non-problematic char */
13457                         if (UTF8_IS_INVARIANT(*s)) {
13458
13459                             /* There are no ascii characters that participate
13460                              * in multi-char folds under /aa.  In EBCDIC, the
13461                              * non-ascii invariants are all control characters,
13462                              * so don't ever participate in any folds. */
13463                             if (ASCII_FOLD_RESTRICTED
13464                                 || ! IS_NON_FINAL_FOLD(*s))
13465                             {
13466                                 break;
13467                             }
13468                         }
13469                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
13470                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
13471                                                                   *s, *(s+1))))
13472                             {
13473                                 break;
13474                             }
13475                         }
13476                         else if (! _invlist_contains_cp(
13477                                         PL_NonL1NonFinalFold,
13478                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
13479                         {
13480                             break;
13481                         }
13482
13483                         /* Here, the current character is problematic in that
13484                          * it does occur in the non-final position of some
13485                          * fold, so try the character before it, but have to
13486                          * special case the very first byte in the string, so
13487                          * we don't read outside the string */
13488                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
13489                     } /* End of loop backwards through the string */
13490
13491                     /* If there were only problematic characters in the string,
13492                      * <s> will point to before s0, in which case the length
13493                      * should be 0, otherwise include the length of the
13494                      * non-problematic character just found */
13495                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
13496                 }
13497
13498                 /* Here, have found the final character, if any, that is
13499                  * non-problematic as far as ending the node without splitting
13500                  * it across a potential multi-char fold.  <len> contains the
13501                  * number of bytes in the node up-to and including that
13502                  * character, or is 0 if there is no such character, meaning
13503                  * the whole node contains only problematic characters.  In
13504                  * this case, give up and just take the node as-is.  We can't
13505                  * do any better */
13506                 if (len == 0) {
13507                     len = full_len;
13508
13509                     /* If the node ends in an 's' we make sure it stays EXACTF,
13510                      * as if it turns into an EXACTFU, it could later get
13511                      * joined with another 's' that would then wrongly match
13512                      * the sharp s */
13513                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
13514                     {
13515                         maybe_exactfu = FALSE;
13516                     }
13517                 } else {
13518
13519                     /* Here, the node does contain some characters that aren't
13520                      * problematic.  If one such is the final character in the
13521                      * node, we are done */
13522                     if (len == full_len) {
13523                         goto loopdone;
13524                     }
13525                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
13526
13527                         /* If the final character is problematic, but the
13528                          * penultimate is not, back-off that last character to
13529                          * later start a new node with it */
13530                         p = oldp;
13531                         goto loopdone;
13532                     }
13533
13534                     /* Here, the final non-problematic character is earlier
13535                      * in the input than the penultimate character.  What we do
13536                      * is reparse from the beginning, going up only as far as
13537                      * this final ok one, thus guaranteeing that the node ends
13538                      * in an acceptable character.  The reason we reparse is
13539                      * that we know how far in the character is, but we don't
13540                      * know how to correlate its position with the input parse.
13541                      * An alternate implementation would be to build that
13542                      * correlation as we go along during the original parse,
13543                      * but that would entail extra work for every node, whereas
13544                      * this code gets executed only when the string is too
13545                      * large for the node, and the final two characters are
13546                      * problematic, an infrequent occurrence.  Yet another
13547                      * possible strategy would be to save the tail of the
13548                      * string, and the next time regatom is called, initialize
13549                      * with that.  The problem with this is that unless you
13550                      * back off one more character, you won't be guaranteed
13551                      * regatom will get called again, unless regbranch,
13552                      * regpiece ... are also changed.  If you do back off that
13553                      * extra character, so that there is input guaranteed to
13554                      * force calling regatom, you can't handle the case where
13555                      * just the first character in the node is acceptable.  I
13556                      * (khw) decided to try this method which doesn't have that
13557                      * pitfall; if performance issues are found, we can do a
13558                      * combination of the current approach plus that one */
13559                     upper_parse = len;
13560                     len = 0;
13561                     s = s0;
13562                     goto reparse;
13563                 }
13564             }   /* End of verifying node ends with an appropriate char */
13565
13566           loopdone:   /* Jumped to when encounters something that shouldn't be
13567                          in the node */
13568
13569             /* I (khw) don't know if you can get here with zero length, but the
13570              * old code handled this situation by creating a zero-length EXACT
13571              * node.  Might as well be NOTHING instead */
13572             if (len == 0) {
13573                 OP(ret) = NOTHING;
13574             }
13575             else {
13576                 if (FOLD) {
13577                     /* If 'maybe_exact' is still set here, means there are no
13578                      * code points in the node that participate in folds;
13579                      * similarly for 'maybe_exactfu' and code points that match
13580                      * differently depending on UTF8ness of the target string
13581                      * (for /u), or depending on locale for /l */
13582                     if (maybe_exact) {
13583                         OP(ret) = (LOC)
13584                                   ? EXACTL
13585                                   : EXACT;
13586                     }
13587                     else if (maybe_exactfu) {
13588                         OP(ret) = (LOC)
13589                                   ? EXACTFLU8
13590                                   : EXACTFU;
13591                     }
13592                 }
13593                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
13594                                            FALSE /* Don't look to see if could
13595                                                     be turned into an EXACT
13596                                                     node, as we have already
13597                                                     computed that */
13598                                           );
13599             }
13600
13601             RExC_parse = p - 1;
13602             Set_Node_Cur_Length(ret, parse_start);
13603             RExC_parse = p;
13604             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13605                                     FALSE /* Don't force to /x */ );
13606             {
13607                 /* len is STRLEN which is unsigned, need to copy to signed */
13608                 IV iv = len;
13609                 if (iv < 0)
13610                     vFAIL("Internal disaster");
13611             }
13612
13613         } /* End of label 'defchar:' */
13614         break;
13615     } /* End of giant switch on input character */
13616
13617     return(ret);
13618 }
13619
13620
13621 STATIC void
13622 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
13623 {
13624     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13625      * sets up the bitmap and any flags, removing those code points from the
13626      * inversion list, setting it to NULL should it become completely empty */
13627
13628     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13629     assert(PL_regkind[OP(node)] == ANYOF);
13630
13631     ANYOF_BITMAP_ZERO(node);
13632     if (*invlist_ptr) {
13633
13634         /* This gets set if we actually need to modify things */
13635         bool change_invlist = FALSE;
13636
13637         UV start, end;
13638
13639         /* Start looking through *invlist_ptr */
13640         invlist_iterinit(*invlist_ptr);
13641         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13642             UV high;
13643             int i;
13644
13645             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13646                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13647             }
13648
13649             /* Quit if are above what we should change */
13650             if (start >= NUM_ANYOF_CODE_POINTS) {
13651                 break;
13652             }
13653
13654             change_invlist = TRUE;
13655
13656             /* Set all the bits in the range, up to the max that we are doing */
13657             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13658                    ? end
13659                    : NUM_ANYOF_CODE_POINTS - 1;
13660             for (i = start; i <= (int) high; i++) {
13661                 if (! ANYOF_BITMAP_TEST(node, i)) {
13662                     ANYOF_BITMAP_SET(node, i);
13663                 }
13664             }
13665         }
13666         invlist_iterfinish(*invlist_ptr);
13667
13668         /* Done with loop; remove any code points that are in the bitmap from
13669          * *invlist_ptr; similarly for code points above the bitmap if we have
13670          * a flag to match all of them anyways */
13671         if (change_invlist) {
13672             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13673         }
13674         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13675             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13676         }
13677
13678         /* If have completely emptied it, remove it completely */
13679         if (_invlist_len(*invlist_ptr) == 0) {
13680             SvREFCNT_dec_NN(*invlist_ptr);
13681             *invlist_ptr = NULL;
13682         }
13683     }
13684 }
13685
13686 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
13687    Character classes ([:foo:]) can also be negated ([:^foo:]).
13688    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
13689    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
13690    but trigger failures because they are currently unimplemented. */
13691
13692 #define POSIXCC_DONE(c)   ((c) == ':')
13693 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
13694 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
13695 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
13696
13697 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
13698 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
13699 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
13700
13701 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
13702
13703 /* 'posix_warnings' and 'warn_text' are names of variables in the following
13704  * routine. q.v. */
13705 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
13706         if (posix_warnings) {                                               \
13707             if (! warn_text) warn_text = newAV();                           \
13708             av_push(warn_text, Perl_newSVpvf(aTHX_                          \
13709                                              WARNING_PREFIX                 \
13710                                              text                           \
13711                                              REPORT_LOCATION,               \
13712                                              REPORT_LOCATION_ARGS(p)));     \
13713         }                                                                   \
13714     } STMT_END
13715
13716 STATIC int
13717 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
13718
13719     const char * const s,      /* Where the putative posix class begins.
13720                                   Normally, this is one past the '['.  This
13721                                   parameter exists so it can be somewhere
13722                                   besides RExC_parse. */
13723     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
13724                                   NULL */
13725     AV ** posix_warnings,      /* Where to place any generated warnings, or
13726                                   NULL */
13727     const bool check_only      /* Don't die if error */
13728 )
13729 {
13730     /* This parses what the caller thinks may be one of the three POSIX
13731      * constructs:
13732      *  1) a character class, like [:blank:]
13733      *  2) a collating symbol, like [. .]
13734      *  3) an equivalence class, like [= =]
13735      * In the latter two cases, it croaks if it finds a syntactically legal
13736      * one, as these are not handled by Perl.
13737      *
13738      * The main purpose is to look for a POSIX character class.  It returns:
13739      *  a) the class number
13740      *      if it is a completely syntactically and semantically legal class.
13741      *      'updated_parse_ptr', if not NULL, is set to point to just after the
13742      *      closing ']' of the class
13743      *  b) OOB_NAMEDCLASS
13744      *      if it appears that one of the three POSIX constructs was meant, but
13745      *      its specification was somehow defective.  'updated_parse_ptr', if
13746      *      not NULL, is set to point to the character just after the end
13747      *      character of the class.  See below for handling of warnings.
13748      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
13749      *      if it  doesn't appear that a POSIX construct was intended.
13750      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
13751      *      raised.
13752      *
13753      * In b) there may be errors or warnings generated.  If 'check_only' is
13754      * TRUE, then any errors are discarded.  Warnings are returned to the
13755      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
13756      * instead it is NULL, warnings are suppressed.  This is done in all
13757      * passes.  The reason for this is that the rest of the parsing is heavily
13758      * dependent on whether this routine found a valid posix class or not.  If
13759      * it did, the closing ']' is absorbed as part of the class.  If no class,
13760      * or an invalid one is found, any ']' will be considered the terminator of
13761      * the outer bracketed character class, leading to very different results.
13762      * In particular, a '(?[ ])' construct will likely have a syntax error if
13763      * the class is parsed other than intended, and this will happen in pass1,
13764      * before the warnings would normally be output.  This mechanism allows the
13765      * caller to output those warnings in pass1 just before dieing, giving a
13766      * much better clue as to what is wrong.
13767      *
13768      * The reason for this function, and its complexity is that a bracketed
13769      * character class can contain just about anything.  But it's easy to
13770      * mistype the very specific posix class syntax but yielding a valid
13771      * regular bracketed class, so it silently gets compiled into something
13772      * quite unintended.
13773      *
13774      * The solution adopted here maintains backward compatibility except that
13775      * it adds a warning if it looks like a posix class was intended but
13776      * improperly specified.  The warning is not raised unless what is input
13777      * very closely resembles one of the 14 legal posix classes.  To do this,
13778      * it uses fuzzy parsing.  It calculates how many single-character edits it
13779      * would take to transform what was input into a legal posix class.  Only
13780      * if that number is quite small does it think that the intention was a
13781      * posix class.  Obviously these are heuristics, and there will be cases
13782      * where it errs on one side or another, and they can be tweaked as
13783      * experience informs.
13784      *
13785      * The syntax for a legal posix class is:
13786      *
13787      * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
13788      *
13789      * What this routine considers syntactically to be an intended posix class
13790      * is this (the comments indicate some restrictions that the pattern
13791      * doesn't show):
13792      *
13793      *  qr/(?x: \[?                         # The left bracket, possibly
13794      *                                      # omitted
13795      *          \h*                         # possibly followed by blanks
13796      *          (?: \^ \h* )?               # possibly a misplaced caret
13797      *          [:;]?                       # The opening class character,
13798      *                                      # possibly omitted.  A typo
13799      *                                      # semi-colon can also be used.
13800      *          \h*
13801      *          \^?                         # possibly a correctly placed
13802      *                                      # caret, but not if there was also
13803      *                                      # a misplaced one
13804      *          \h*
13805      *          .{3,15}                     # The class name.  If there are
13806      *                                      # deviations from the legal syntax,
13807      *                                      # its edit distance must be close
13808      *                                      # to a real class name in order
13809      *                                      # for it to be considered to be
13810      *                                      # an intended posix class.
13811      *          \h*
13812      *          [:punct:]?                  # The closing class character,
13813      *                                      # possibly omitted.  If not a colon
13814      *                                      # nor semi colon, the class name
13815      *                                      # must be even closer to a valid
13816      *                                      # one
13817      *          \h*
13818      *          \]?                         # The right bracket, possibly
13819      *                                      # omitted.
13820      *     )/
13821      *
13822      * In the above, \h must be ASCII-only.
13823      *
13824      * These are heuristics, and can be tweaked as field experience dictates.
13825      * There will be cases when someone didn't intend to specify a posix class
13826      * that this warns as being so.  The goal is to minimize these, while
13827      * maximizing the catching of things intended to be a posix class that
13828      * aren't parsed as such.
13829      */
13830
13831     const char* p             = s;
13832     const char * const e      = RExC_end;
13833     unsigned complement       = 0;      /* If to complement the class */
13834     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
13835     bool has_opening_bracket  = FALSE;
13836     bool has_opening_colon    = FALSE;
13837     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
13838                                                    valid class */
13839     AV* warn_text             = NULL;   /* any warning messages */
13840     const char * possible_end = NULL;   /* used for a 2nd parse pass */
13841     const char* name_start;             /* ptr to class name first char */
13842
13843     /* If the number of single-character typos the input name is away from a
13844      * legal name is no more than this number, it is considered to have meant
13845      * the legal name */
13846     int max_distance          = 2;
13847
13848     /* to store the name.  The size determines the maximum length before we
13849      * decide that no posix class was intended.  Should be at least
13850      * sizeof("alphanumeric") */
13851     UV input_text[15];
13852
13853     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
13854
13855     if (p >= e) {
13856         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
13857     }
13858
13859     if (*(p - 1) != '[') {
13860         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
13861         found_problem = TRUE;
13862     }
13863     else {
13864         has_opening_bracket = TRUE;
13865     }
13866
13867     /* They could be confused and think you can put spaces between the
13868      * components */
13869     if (isBLANK(*p)) {
13870         found_problem = TRUE;
13871
13872         do {
13873             p++;
13874         } while (p < e && isBLANK(*p));
13875
13876         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
13877     }
13878
13879     /* For [. .] and [= =].  These are quite different internally from [: :],
13880      * so they are handled separately.  */
13881     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
13882                                             and 1 for at least one char in it
13883                                           */
13884     {
13885         const char open_char  = *p;
13886         const char * temp_ptr = p + 1;
13887
13888         /* These two constructs are not handled by perl, and if we find a
13889          * syntactically valid one, we croak.  khw, who wrote this code, finds
13890          * this explanation of them very unclear:
13891          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
13892          * And searching the rest of the internet wasn't very helpful either.
13893          * It looks like just about any byte can be in these constructs,
13894          * depending on the locale.  But unless the pattern is being compiled
13895          * under /l, which is very rare, Perl runs under the C or POSIX locale.
13896          * In that case, it looks like [= =] isn't allowed at all, and that
13897          * [. .] could be any single code point, but for longer strings the
13898          * constituent characters would have to be the ASCII alphabetics plus
13899          * the minus-hyphen.  Any sensible locale definition would limit itself
13900          * to these.  And any portable one definitely should.  Trying to parse
13901          * the general case is a nightmare (see [perl #127604]).  So, this code
13902          * looks only for interiors of these constructs that match:
13903          *      qr/.|[-\w]{2,}/
13904          * Using \w relaxes the apparent rules a little, without adding much
13905          * danger of mistaking something else for one of these constructs.
13906          *
13907          * [. .] in some implementations described on the internet is usable to
13908          * escape a character that otherwise is special in bracketed character
13909          * classes.  For example [.].] means a literal right bracket instead of
13910          * the ending of the class
13911          *
13912          * [= =] can legitimately contain a [. .] construct, but we don't
13913          * handle this case, as that [. .] construct will later get parsed
13914          * itself and croak then.  And [= =] is checked for even when not under
13915          * /l, as Perl has long done so.
13916          *
13917          * The code below relies on there being a trailing NUL, so it doesn't
13918          * have to keep checking if the parse ptr < e.
13919          */
13920         if (temp_ptr[1] == open_char) {
13921             temp_ptr++;
13922         }
13923         else while (    temp_ptr < e
13924                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
13925         {
13926             temp_ptr++;
13927         }
13928
13929         if (*temp_ptr == open_char) {
13930             temp_ptr++;
13931             if (*temp_ptr == ']') {
13932                 temp_ptr++;
13933                 if (! found_problem && ! check_only) {
13934                     RExC_parse = (char *) temp_ptr;
13935                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
13936                             "extensions", open_char, open_char);
13937                 }
13938
13939                 /* Here, the syntax wasn't completely valid, or else the call
13940                  * is to check-only */
13941                 if (updated_parse_ptr) {
13942                     *updated_parse_ptr = (char *) temp_ptr;
13943                 }
13944
13945                 return OOB_NAMEDCLASS;
13946             }
13947         }
13948
13949         /* If we find something that started out to look like one of these
13950          * constructs, but isn't, we continue below so that it can be checked
13951          * for being a class name with a typo of '.' or '=' instead of a colon.
13952          * */
13953     }
13954
13955     /* Here, we think there is a possibility that a [: :] class was meant, and
13956      * we have the first real character.  It could be they think the '^' comes
13957      * first */
13958     if (*p == '^') {
13959         found_problem = TRUE;
13960         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
13961         complement = 1;
13962         p++;
13963
13964         if (isBLANK(*p)) {
13965             found_problem = TRUE;
13966
13967             do {
13968                 p++;
13969             } while (p < e && isBLANK(*p));
13970
13971             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
13972         }
13973     }
13974
13975     /* But the first character should be a colon, which they could have easily
13976      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
13977      * distinguish from a colon, so treat that as a colon).  */
13978     if (*p == ':') {
13979         p++;
13980         has_opening_colon = TRUE;
13981     }
13982     else if (*p == ';') {
13983         found_problem = TRUE;
13984         p++;
13985         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
13986         has_opening_colon = TRUE;
13987     }
13988     else {
13989         found_problem = TRUE;
13990         ADD_POSIX_WARNING(p, "there must be a starting ':'");
13991
13992         /* Consider an initial punctuation (not one of the recognized ones) to
13993          * be a left terminator */
13994         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
13995             p++;
13996         }
13997     }
13998
13999     /* They may think that you can put spaces between the components */
14000     if (isBLANK(*p)) {
14001         found_problem = TRUE;
14002
14003         do {
14004             p++;
14005         } while (p < e && isBLANK(*p));
14006
14007         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14008     }
14009
14010     if (*p == '^') {
14011
14012         /* We consider something like [^:^alnum:]] to not have been intended to
14013          * be a posix class, but XXX maybe we should */
14014         if (complement) {
14015             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14016         }
14017
14018         complement = 1;
14019         p++;
14020     }
14021
14022     /* Again, they may think that you can put spaces between the components */
14023     if (isBLANK(*p)) {
14024         found_problem = TRUE;
14025
14026         do {
14027             p++;
14028         } while (p < e && isBLANK(*p));
14029
14030         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14031     }
14032
14033     if (*p == ']') {
14034
14035         /* XXX This ']' may be a typo, and something else was meant.  But
14036          * treating it as such creates enough complications, that that
14037          * possibility isn't currently considered here.  So we assume that the
14038          * ']' is what is intended, and if we've already found an initial '[',
14039          * this leaves this construct looking like [:] or [:^], which almost
14040          * certainly weren't intended to be posix classes */
14041         if (has_opening_bracket) {
14042             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14043         }
14044
14045         /* But this function can be called when we parse the colon for
14046          * something like qr/[alpha:]]/, so we back up to look for the
14047          * beginning */
14048         p--;
14049
14050         if (*p == ';') {
14051             found_problem = TRUE;
14052             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14053         }
14054         else if (*p != ':') {
14055
14056             /* XXX We are currently very restrictive here, so this code doesn't
14057              * consider the possibility that, say, /[alpha.]]/ was intended to
14058              * be a posix class. */
14059             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14060         }
14061
14062         /* Here we have something like 'foo:]'.  There was no initial colon,
14063          * and we back up over 'foo.  XXX Unlike the going forward case, we
14064          * don't handle typos of non-word chars in the middle */
14065         has_opening_colon = FALSE;
14066         p--;
14067
14068         while (p > RExC_start && isWORDCHAR(*p)) {
14069             p--;
14070         }
14071         p++;
14072
14073         /* Here, we have positioned ourselves to where we think the first
14074          * character in the potential class is */
14075     }
14076
14077     /* Now the interior really starts.  There are certain key characters that
14078      * can end the interior, or these could just be typos.  To catch both
14079      * cases, we may have to do two passes.  In the first pass, we keep on
14080      * going unless we come to a sequence that matches
14081      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14082      * This means it takes a sequence to end the pass, so two typos in a row if
14083      * that wasn't what was intended.  If the class is perfectly formed, just
14084      * this one pass is needed.  We also stop if there are too many characters
14085      * being accumulated, but this number is deliberately set higher than any
14086      * real class.  It is set high enough so that someone who thinks that
14087      * 'alphanumeric' is a correct name would get warned that it wasn't.
14088      * While doing the pass, we keep track of where the key characters were in
14089      * it.  If we don't find an end to the class, and one of the key characters
14090      * was found, we redo the pass, but stop when we get to that character.
14091      * Thus the key character was considered a typo in the first pass, but a
14092      * terminator in the second.  If two key characters are found, we stop at
14093      * the second one in the first pass.  Again this can miss two typos, but
14094      * catches a single one
14095      *
14096      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14097      * point to the first key character.  For the second pass, it starts as -1.
14098      * */
14099
14100     name_start = p;
14101   parse_name:
14102     {
14103         bool has_blank               = FALSE;
14104         bool has_upper               = FALSE;
14105         bool has_terminating_colon   = FALSE;
14106         bool has_terminating_bracket = FALSE;
14107         bool has_semi_colon          = FALSE;
14108         unsigned int name_len        = 0;
14109         int punct_count              = 0;
14110
14111         while (p < e) {
14112
14113             /* Squeeze out blanks when looking up the class name below */
14114             if (isBLANK(*p) ) {
14115                 has_blank = TRUE;
14116                 found_problem = TRUE;
14117                 p++;
14118                 continue;
14119             }
14120
14121             /* The name will end with a punctuation */
14122             if (isPUNCT(*p)) {
14123                 const char * peek = p + 1;
14124
14125                 /* Treat any non-']' punctuation followed by a ']' (possibly
14126                  * with intervening blanks) as trying to terminate the class.
14127                  * ']]' is very likely to mean a class was intended (but
14128                  * missing the colon), but the warning message that gets
14129                  * generated shows the error position better if we exit the
14130                  * loop at the bottom (eventually), so skip it here. */
14131                 if (*p != ']') {
14132                     if (peek < e && isBLANK(*peek)) {
14133                         has_blank = TRUE;
14134                         found_problem = TRUE;
14135                         do {
14136                             peek++;
14137                         } while (peek < e && isBLANK(*peek));
14138                     }
14139
14140                     if (peek < e && *peek == ']') {
14141                         has_terminating_bracket = TRUE;
14142                         if (*p == ':') {
14143                             has_terminating_colon = TRUE;
14144                         }
14145                         else if (*p == ';') {
14146                             has_semi_colon = TRUE;
14147                             has_terminating_colon = TRUE;
14148                         }
14149                         else {
14150                             found_problem = TRUE;
14151                         }
14152                         p = peek + 1;
14153                         goto try_posix;
14154                     }
14155                 }
14156
14157                 /* Here we have punctuation we thought didn't end the class.
14158                  * Keep track of the position of the key characters that are
14159                  * more likely to have been class-enders */
14160                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14161
14162                     /* Allow just one such possible class-ender not actually
14163                      * ending the class. */
14164                     if (possible_end) {
14165                         break;
14166                     }
14167                     possible_end = p;
14168                 }
14169
14170                 /* If we have too many punctuation characters, no use in
14171                  * keeping going */
14172                 if (++punct_count > max_distance) {
14173                     break;
14174                 }
14175
14176                 /* Treat the punctuation as a typo. */
14177                 input_text[name_len++] = *p;
14178                 p++;
14179             }
14180             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14181                 input_text[name_len++] = toLOWER(*p);
14182                 has_upper = TRUE;
14183                 found_problem = TRUE;
14184                 p++;
14185             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14186                 input_text[name_len++] = *p;
14187                 p++;
14188             }
14189             else {
14190                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14191                 p+= UTF8SKIP(p);
14192             }
14193
14194             /* The declaration of 'input_text' is how long we allow a potential
14195              * class name to be, before saying they didn't mean a class name at
14196              * all */
14197             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14198                 break;
14199             }
14200         }
14201
14202         /* We get to here when the possible class name hasn't been properly
14203          * terminated before:
14204          *   1) we ran off the end of the pattern; or
14205          *   2) found two characters, each of which might have been intended to
14206          *      be the name's terminator
14207          *   3) found so many punctuation characters in the purported name,
14208          *      that the edit distance to a valid one is exceeded
14209          *   4) we decided it was more characters than anyone could have
14210          *      intended to be one. */
14211
14212         found_problem = TRUE;
14213
14214         /* In the final two cases, we know that looking up what we've
14215          * accumulated won't lead to a match, even a fuzzy one. */
14216         if (   name_len >= C_ARRAY_LENGTH(input_text)
14217             || punct_count > max_distance)
14218         {
14219             /* If there was an intermediate key character that could have been
14220              * an intended end, redo the parse, but stop there */
14221             if (possible_end && possible_end != (char *) -1) {
14222                 possible_end = (char *) -1; /* Special signal value to say
14223                                                we've done a first pass */
14224                 p = name_start;
14225                 goto parse_name;
14226             }
14227
14228             /* Otherwise, it can't have meant to have been a class */
14229             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14230         }
14231
14232         /* If we ran off the end, and the final character was a punctuation
14233          * one, back up one, to look at that final one just below.  Later, we
14234          * will restore the parse pointer if appropriate */
14235         if (name_len && p == e && isPUNCT(*(p-1))) {
14236             p--;
14237             name_len--;
14238         }
14239
14240         if (p < e && isPUNCT(*p)) {
14241             if (*p == ']') {
14242                 has_terminating_bracket = TRUE;
14243
14244                 /* If this is a 2nd ']', and the first one is just below this
14245                  * one, consider that to be the real terminator.  This gives a
14246                  * uniform and better positioning for the warning message  */
14247                 if (   possible_end
14248                     && possible_end != (char *) -1
14249                     && *possible_end == ']'
14250                     && name_len && input_text[name_len - 1] == ']')
14251                 {
14252                     name_len--;
14253                     p = possible_end;
14254
14255                     /* And this is actually equivalent to having done the 2nd
14256                      * pass now, so set it to not try again */
14257                     possible_end = (char *) -1;
14258                 }
14259             }
14260             else {
14261                 if (*p == ':') {
14262                     has_terminating_colon = TRUE;
14263                 }
14264                 else if (*p == ';') {
14265                     has_semi_colon = TRUE;
14266                     has_terminating_colon = TRUE;
14267                 }
14268                 p++;
14269             }
14270         }
14271
14272     try_posix:
14273
14274         /* Here, we have a class name to look up.  We can short circuit the
14275          * stuff below for short names that can't possibly be meant to be a
14276          * class name.  (We can do this on the first pass, as any second pass
14277          * will yield an even shorter name) */
14278         if (name_len < 3) {
14279             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14280         }
14281
14282         /* Find which class it is.  Initially switch on the length of the name.
14283          * */
14284         switch (name_len) {
14285             case 4:
14286                 if (memEQ(name_start, "word", 4)) {
14287                     /* this is not POSIX, this is the Perl \w */
14288                     class_number = ANYOF_WORDCHAR;
14289                 }
14290                 break;
14291             case 5:
14292                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14293                  *                        graph lower print punct space upper
14294                  * Offset 4 gives the best switch position.  */
14295                 switch (name_start[4]) {
14296                     case 'a':
14297                         if (memEQ(name_start, "alph", 4)) /* alpha */
14298                             class_number = ANYOF_ALPHA;
14299                         break;
14300                     case 'e':
14301                         if (memEQ(name_start, "spac", 4)) /* space */
14302                             class_number = ANYOF_SPACE;
14303                         break;
14304                     case 'h':
14305                         if (memEQ(name_start, "grap", 4)) /* graph */
14306                             class_number = ANYOF_GRAPH;
14307                         break;
14308                     case 'i':
14309                         if (memEQ(name_start, "asci", 4)) /* ascii */
14310                             class_number = ANYOF_ASCII;
14311                         break;
14312                     case 'k':
14313                         if (memEQ(name_start, "blan", 4)) /* blank */
14314                             class_number = ANYOF_BLANK;
14315                         break;
14316                     case 'l':
14317                         if (memEQ(name_start, "cntr", 4)) /* cntrl */
14318                             class_number = ANYOF_CNTRL;
14319                         break;
14320                     case 'm':
14321                         if (memEQ(name_start, "alnu", 4)) /* alnum */
14322                             class_number = ANYOF_ALPHANUMERIC;
14323                         break;
14324                     case 'r':
14325                         if (memEQ(name_start, "lowe", 4)) /* lower */
14326                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
14327                         else if (memEQ(name_start, "uppe", 4)) /* upper */
14328                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
14329                         break;
14330                     case 't':
14331                         if (memEQ(name_start, "digi", 4)) /* digit */
14332                             class_number = ANYOF_DIGIT;
14333                         else if (memEQ(name_start, "prin", 4)) /* print */
14334                             class_number = ANYOF_PRINT;
14335                         else if (memEQ(name_start, "punc", 4)) /* punct */
14336                             class_number = ANYOF_PUNCT;
14337                         break;
14338                 }
14339                 break;
14340             case 6:
14341                 if (memEQ(name_start, "xdigit", 6))
14342                     class_number = ANYOF_XDIGIT;
14343                 break;
14344         }
14345
14346         /* If the name exactly matches a posix class name the class number will
14347          * here be set to it, and the input almost certainly was meant to be a
14348          * posix class, so we can skip further checking.  If instead the syntax
14349          * is exactly correct, but the name isn't one of the legal ones, we
14350          * will return that as an error below.  But if neither of these apply,
14351          * it could be that no posix class was intended at all, or that one
14352          * was, but there was a typo.  We tease these apart by doing fuzzy
14353          * matching on the name */
14354         if (class_number == OOB_NAMEDCLASS && found_problem) {
14355             const UV posix_names[][6] = {
14356                                                 { 'a', 'l', 'n', 'u', 'm' },
14357                                                 { 'a', 'l', 'p', 'h', 'a' },
14358                                                 { 'a', 's', 'c', 'i', 'i' },
14359                                                 { 'b', 'l', 'a', 'n', 'k' },
14360                                                 { 'c', 'n', 't', 'r', 'l' },
14361                                                 { 'd', 'i', 'g', 'i', 't' },
14362                                                 { 'g', 'r', 'a', 'p', 'h' },
14363                                                 { 'l', 'o', 'w', 'e', 'r' },
14364                                                 { 'p', 'r', 'i', 'n', 't' },
14365                                                 { 'p', 'u', 'n', 'c', 't' },
14366                                                 { 's', 'p', 'a', 'c', 'e' },
14367                                                 { 'u', 'p', 'p', 'e', 'r' },
14368                                                 { 'w', 'o', 'r', 'd' },
14369                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
14370                                             };
14371             /* The names of the above all have added NULs to make them the same
14372              * size, so we need to also have the real lengths */
14373             const UV posix_name_lengths[] = {
14374                                                 sizeof("alnum") - 1,
14375                                                 sizeof("alpha") - 1,
14376                                                 sizeof("ascii") - 1,
14377                                                 sizeof("blank") - 1,
14378                                                 sizeof("cntrl") - 1,
14379                                                 sizeof("digit") - 1,
14380                                                 sizeof("graph") - 1,
14381                                                 sizeof("lower") - 1,
14382                                                 sizeof("print") - 1,
14383                                                 sizeof("punct") - 1,
14384                                                 sizeof("space") - 1,
14385                                                 sizeof("upper") - 1,
14386                                                 sizeof("word")  - 1,
14387                                                 sizeof("xdigit")- 1
14388                                             };
14389             unsigned int i;
14390             int temp_max = max_distance;    /* Use a temporary, so if we
14391                                                reparse, we haven't changed the
14392                                                outer one */
14393
14394             /* Use a smaller max edit distance if we are missing one of the
14395              * delimiters */
14396             if (   has_opening_bracket + has_opening_colon < 2
14397                 || has_terminating_bracket + has_terminating_colon < 2)
14398             {
14399                 temp_max--;
14400             }
14401
14402             /* See if the input name is close to a legal one */
14403             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
14404
14405                 /* Short circuit call if the lengths are too far apart to be
14406                  * able to match */
14407                 if (abs( (int) (name_len - posix_name_lengths[i]))
14408                     > temp_max)
14409                 {
14410                     continue;
14411                 }
14412
14413                 if (edit_distance(input_text,
14414                                   posix_names[i],
14415                                   name_len,
14416                                   posix_name_lengths[i],
14417                                   temp_max
14418                                  )
14419                     > -1)
14420                 { /* If it is close, it probably was intended to be a class */
14421                     goto probably_meant_to_be;
14422                 }
14423             }
14424
14425             /* Here the input name is not close enough to a valid class name
14426              * for us to consider it to be intended to be a posix class.  If
14427              * we haven't already done so, and the parse found a character that
14428              * could have been terminators for the name, but which we absorbed
14429              * as typos during the first pass, repeat the parse, signalling it
14430              * to stop at that character */
14431             if (possible_end && possible_end != (char *) -1) {
14432                 possible_end = (char *) -1;
14433                 p = name_start;
14434                 goto parse_name;
14435             }
14436
14437             /* Here neither pass found a close-enough class name */
14438             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14439         }
14440
14441     probably_meant_to_be:
14442
14443         /* Here we think that a posix specification was intended.  Update any
14444          * parse pointer */
14445         if (updated_parse_ptr) {
14446             *updated_parse_ptr = (char *) p;
14447         }
14448
14449         /* If a posix class name was intended but incorrectly specified, we
14450          * output or return the warnings */
14451         if (found_problem) {
14452
14453             /* We set flags for these issues in the parse loop above instead of
14454              * adding them to the list of warnings, because we can parse it
14455              * twice, and we only want one warning instance */
14456             if (has_upper) {
14457                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
14458             }
14459             if (has_blank) {
14460                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14461             }
14462             if (has_semi_colon) {
14463                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14464             }
14465             else if (! has_terminating_colon) {
14466                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
14467             }
14468             if (! has_terminating_bracket) {
14469                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
14470             }
14471
14472             if (warn_text) {
14473                 if (posix_warnings) {
14474                     /* mortalize to avoid a leak with FATAL warnings */
14475                     *posix_warnings = (AV *) sv_2mortal((SV *) warn_text);
14476                 }
14477                 else {
14478                     SvREFCNT_dec_NN(warn_text);
14479                 }
14480             }
14481         }
14482         else if (class_number != OOB_NAMEDCLASS) {
14483             /* If it is a known class, return the class.  The class number
14484              * #defines are structured so each complement is +1 to the normal
14485              * one */
14486             return class_number + complement;
14487         }
14488         else if (! check_only) {
14489
14490             /* Here, it is an unrecognized class.  This is an error (unless the
14491             * call is to check only, which we've already handled above) */
14492             const char * const complement_string = (complement)
14493                                                    ? "^"
14494                                                    : "";
14495             RExC_parse = (char *) p;
14496             vFAIL3utf8f("POSIX class [:%s%"UTF8f":] unknown",
14497                         complement_string,
14498                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
14499         }
14500     }
14501
14502     return OOB_NAMEDCLASS;
14503 }
14504 #undef ADD_POSIX_WARNING
14505
14506 STATIC unsigned  int
14507 S_regex_set_precedence(const U8 my_operator) {
14508
14509     /* Returns the precedence in the (?[...]) construct of the input operator,
14510      * specified by its character representation.  The precedence follows
14511      * general Perl rules, but it extends this so that ')' and ']' have (low)
14512      * precedence even though they aren't really operators */
14513
14514     switch (my_operator) {
14515         case '!':
14516             return 5;
14517         case '&':
14518             return 4;
14519         case '^':
14520         case '|':
14521         case '+':
14522         case '-':
14523             return 3;
14524         case ')':
14525             return 2;
14526         case ']':
14527             return 1;
14528     }
14529
14530     NOT_REACHED; /* NOTREACHED */
14531     return 0;   /* Silence compiler warning */
14532 }
14533
14534 STATIC regnode *
14535 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
14536                     I32 *flagp, U32 depth,
14537                     char * const oregcomp_parse)
14538 {
14539     /* Handle the (?[...]) construct to do set operations */
14540
14541     U8 curchar;                     /* Current character being parsed */
14542     UV start, end;                  /* End points of code point ranges */
14543     SV* final = NULL;               /* The end result inversion list */
14544     SV* result_string;              /* 'final' stringified */
14545     AV* stack;                      /* stack of operators and operands not yet
14546                                        resolved */
14547     AV* fence_stack = NULL;         /* A stack containing the positions in
14548                                        'stack' of where the undealt-with left
14549                                        parens would be if they were actually
14550                                        put there */
14551     /* The 'VOL' (expanding to 'volatile') is a workaround for an optimiser bug
14552      * in Solaris Studio 12.3. See RT #127455 */
14553     VOL IV fence = 0;               /* Position of where most recent undealt-
14554                                        with left paren in stack is; -1 if none.
14555                                      */
14556     STRLEN len;                     /* Temporary */
14557     regnode* node;                  /* Temporary, and final regnode returned by
14558                                        this function */
14559     const bool save_fold = FOLD;    /* Temporary */
14560     char *save_end, *save_parse;    /* Temporaries */
14561     const bool in_locale = LOC;     /* we turn off /l during processing */
14562     AV* posix_warnings = NULL;
14563
14564     GET_RE_DEBUG_FLAGS_DECL;
14565
14566     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
14567
14568     if (in_locale) {
14569         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
14570     }
14571
14572     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
14573                                          This is required so that the compile
14574                                          time values are valid in all runtime
14575                                          cases */
14576
14577     /* This will return only an ANYOF regnode, or (unlikely) something smaller
14578      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
14579      * call regclass to handle '[]' so as to not have to reinvent its parsing
14580      * rules here (throwing away the size it computes each time).  And, we exit
14581      * upon an unescaped ']' that isn't one ending a regclass.  To do both
14582      * these things, we need to realize that something preceded by a backslash
14583      * is escaped, so we have to keep track of backslashes */
14584     if (SIZE_ONLY) {
14585         UV depth = 0; /* how many nested (?[...]) constructs */
14586
14587         while (RExC_parse < RExC_end) {
14588             SV* current = NULL;
14589
14590             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14591                                     TRUE /* Force /x */ );
14592
14593             switch (*RExC_parse) {
14594                 case '?':
14595                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
14596                     /* FALLTHROUGH */
14597                 default:
14598                     break;
14599                 case '\\':
14600                     /* Skip past this, so the next character gets skipped, after
14601                      * the switch */
14602                     RExC_parse++;
14603                     if (*RExC_parse == 'c') {
14604                             /* Skip the \cX notation for control characters */
14605                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14606                     }
14607                     break;
14608
14609                 case '[':
14610                 {
14611                     /* See if this is a [:posix:] class. */
14612                     bool is_posix_class = (OOB_NAMEDCLASS
14613                             < handle_possible_posix(pRExC_state,
14614                                                 RExC_parse + 1,
14615                                                 NULL,
14616                                                 NULL,
14617                                                 TRUE /* checking only */));
14618                     /* If it is a posix class, leave the parse pointer at the
14619                      * '[' to fool regclass() into thinking it is part of a
14620                      * '[[:posix:]]'. */
14621                     if (! is_posix_class) {
14622                         RExC_parse++;
14623                     }
14624
14625                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
14626                      * if multi-char folds are allowed.  */
14627                     if (!regclass(pRExC_state, flagp,depth+1,
14628                                   is_posix_class, /* parse the whole char
14629                                                      class only if not a
14630                                                      posix class */
14631                                   FALSE, /* don't allow multi-char folds */
14632                                   TRUE, /* silence non-portable warnings. */
14633                                   TRUE, /* strict */
14634                                   FALSE, /* Require return to be an ANYOF */
14635                                   &current,
14636                                   &posix_warnings
14637                                  ))
14638                         FAIL2("panic: regclass returned NULL to handle_sets, "
14639                               "flags=%#"UVxf"", (UV) *flagp);
14640
14641                     /* function call leaves parse pointing to the ']', except
14642                      * if we faked it */
14643                     if (is_posix_class) {
14644                         RExC_parse--;
14645                     }
14646
14647                     SvREFCNT_dec(current);   /* In case it returned something */
14648                     break;
14649                 }
14650
14651                 case ']':
14652                     if (depth--) break;
14653                     RExC_parse++;
14654                     if (*RExC_parse == ')') {
14655                         node = reganode(pRExC_state, ANYOF, 0);
14656                         RExC_size += ANYOF_SKIP;
14657                         nextchar(pRExC_state);
14658                         Set_Node_Length(node,
14659                                 RExC_parse - oregcomp_parse + 1); /* MJD */
14660                         if (in_locale) {
14661                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
14662                         }
14663
14664                         return node;
14665                     }
14666                     goto no_close;
14667             }
14668
14669             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14670         }
14671
14672       no_close:
14673         /* We output the messages even if warnings are off, because we'll fail
14674          * the very next thing, and these give a likely diagnosis for that */
14675         if (posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
14676             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
14677         }
14678
14679         FAIL("Syntax error in (?[...])");
14680     }
14681
14682     /* Pass 2 only after this. */
14683     Perl_ck_warner_d(aTHX_
14684         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
14685         "The regex_sets feature is experimental" REPORT_LOCATION,
14686         REPORT_LOCATION_ARGS(RExC_parse));
14687
14688     /* Everything in this construct is a metacharacter.  Operands begin with
14689      * either a '\' (for an escape sequence), or a '[' for a bracketed
14690      * character class.  Any other character should be an operator, or
14691      * parenthesis for grouping.  Both types of operands are handled by calling
14692      * regclass() to parse them.  It is called with a parameter to indicate to
14693      * return the computed inversion list.  The parsing here is implemented via
14694      * a stack.  Each entry on the stack is a single character representing one
14695      * of the operators; or else a pointer to an operand inversion list. */
14696
14697 #define IS_OPERATOR(a) SvIOK(a)
14698 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
14699
14700     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
14701      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
14702      * with pronouncing it called it Reverse Polish instead, but now that YOU
14703      * know how to pronounce it you can use the correct term, thus giving due
14704      * credit to the person who invented it, and impressing your geek friends.
14705      * Wikipedia says that the pronounciation of "Ł" has been changing so that
14706      * it is now more like an English initial W (as in wonk) than an L.)
14707      *
14708      * This means that, for example, 'a | b & c' is stored on the stack as
14709      *
14710      * c  [4]
14711      * b  [3]
14712      * &  [2]
14713      * a  [1]
14714      * |  [0]
14715      *
14716      * where the numbers in brackets give the stack [array] element number.
14717      * In this implementation, parentheses are not stored on the stack.
14718      * Instead a '(' creates a "fence" so that the part of the stack below the
14719      * fence is invisible except to the corresponding ')' (this allows us to
14720      * replace testing for parens, by using instead subtraction of the fence
14721      * position).  As new operands are processed they are pushed onto the stack
14722      * (except as noted in the next paragraph).  New operators of higher
14723      * precedence than the current final one are inserted on the stack before
14724      * the lhs operand (so that when the rhs is pushed next, everything will be
14725      * in the correct positions shown above.  When an operator of equal or
14726      * lower precedence is encountered in parsing, all the stacked operations
14727      * of equal or higher precedence are evaluated, leaving the result as the
14728      * top entry on the stack.  This makes higher precedence operations
14729      * evaluate before lower precedence ones, and causes operations of equal
14730      * precedence to left associate.
14731      *
14732      * The only unary operator '!' is immediately pushed onto the stack when
14733      * encountered.  When an operand is encountered, if the top of the stack is
14734      * a '!", the complement is immediately performed, and the '!' popped.  The
14735      * resulting value is treated as a new operand, and the logic in the
14736      * previous paragraph is executed.  Thus in the expression
14737      *      [a] + ! [b]
14738      * the stack looks like
14739      *
14740      * !
14741      * a
14742      * +
14743      *
14744      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
14745      * becomes
14746      *
14747      * !b
14748      * a
14749      * +
14750      *
14751      * A ')' is treated as an operator with lower precedence than all the
14752      * aforementioned ones, which causes all operations on the stack above the
14753      * corresponding '(' to be evaluated down to a single resultant operand.
14754      * Then the fence for the '(' is removed, and the operand goes through the
14755      * algorithm above, without the fence.
14756      *
14757      * A separate stack is kept of the fence positions, so that the position of
14758      * the latest so-far unbalanced '(' is at the top of it.
14759      *
14760      * The ']' ending the construct is treated as the lowest operator of all,
14761      * so that everything gets evaluated down to a single operand, which is the
14762      * result */
14763
14764     sv_2mortal((SV *)(stack = newAV()));
14765     sv_2mortal((SV *)(fence_stack = newAV()));
14766
14767     while (RExC_parse < RExC_end) {
14768         I32 top_index;              /* Index of top-most element in 'stack' */
14769         SV** top_ptr;               /* Pointer to top 'stack' element */
14770         SV* current = NULL;         /* To contain the current inversion list
14771                                        operand */
14772         SV* only_to_avoid_leaks;
14773
14774         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14775                                 TRUE /* Force /x */ );
14776         if (RExC_parse >= RExC_end) {
14777             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
14778         }
14779
14780         curchar = UCHARAT(RExC_parse);
14781
14782 redo_curchar:
14783
14784         top_index = av_tindex_nomg(stack);
14785
14786         switch (curchar) {
14787             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
14788             char stacked_operator;  /* The topmost operator on the 'stack'. */
14789             SV* lhs;                /* Operand to the left of the operator */
14790             SV* rhs;                /* Operand to the right of the operator */
14791             SV* fence_ptr;          /* Pointer to top element of the fence
14792                                        stack */
14793
14794             case '(':
14795
14796                 if (   RExC_parse < RExC_end - 1
14797                     && (UCHARAT(RExC_parse + 1) == '?'))
14798                 {
14799                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
14800                      * This happens when we have some thing like
14801                      *
14802                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
14803                      *   ...
14804                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
14805                      *
14806                      * Here we would be handling the interpolated
14807                      * '$thai_or_lao'.  We handle this by a recursive call to
14808                      * ourselves which returns the inversion list the
14809                      * interpolated expression evaluates to.  We use the flags
14810                      * from the interpolated pattern. */
14811                     U32 save_flags = RExC_flags;
14812                     const char * save_parse;
14813
14814                     RExC_parse += 2;        /* Skip past the '(?' */
14815                     save_parse = RExC_parse;
14816
14817                     /* Parse any flags for the '(?' */
14818                     parse_lparen_question_flags(pRExC_state);
14819
14820                     if (RExC_parse == save_parse  /* Makes sure there was at
14821                                                      least one flag (or else
14822                                                      this embedding wasn't
14823                                                      compiled) */
14824                         || RExC_parse >= RExC_end - 4
14825                         || UCHARAT(RExC_parse) != ':'
14826                         || UCHARAT(++RExC_parse) != '('
14827                         || UCHARAT(++RExC_parse) != '?'
14828                         || UCHARAT(++RExC_parse) != '[')
14829                     {
14830
14831                         /* In combination with the above, this moves the
14832                          * pointer to the point just after the first erroneous
14833                          * character (or if there are no flags, to where they
14834                          * should have been) */
14835                         if (RExC_parse >= RExC_end - 4) {
14836                             RExC_parse = RExC_end;
14837                         }
14838                         else if (RExC_parse != save_parse) {
14839                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
14840                         }
14841                         vFAIL("Expecting '(?flags:(?[...'");
14842                     }
14843
14844                     /* Recurse, with the meat of the embedded expression */
14845                     RExC_parse++;
14846                     (void) handle_regex_sets(pRExC_state, &current, flagp,
14847                                                     depth+1, oregcomp_parse);
14848
14849                     /* Here, 'current' contains the embedded expression's
14850                      * inversion list, and RExC_parse points to the trailing
14851                      * ']'; the next character should be the ')' */
14852                     RExC_parse++;
14853                     assert(UCHARAT(RExC_parse) == ')');
14854
14855                     /* Then the ')' matching the original '(' handled by this
14856                      * case: statement */
14857                     RExC_parse++;
14858                     assert(UCHARAT(RExC_parse) == ')');
14859
14860                     RExC_parse++;
14861                     RExC_flags = save_flags;
14862                     goto handle_operand;
14863                 }
14864
14865                 /* A regular '('.  Look behind for illegal syntax */
14866                 if (top_index - fence >= 0) {
14867                     /* If the top entry on the stack is an operator, it had
14868                      * better be a '!', otherwise the entry below the top
14869                      * operand should be an operator */
14870                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
14871                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
14872                         || (   IS_OPERAND(*top_ptr)
14873                             && (   top_index - fence < 1
14874                                 || ! (stacked_ptr = av_fetch(stack,
14875                                                              top_index - 1,
14876                                                              FALSE))
14877                                 || ! IS_OPERATOR(*stacked_ptr))))
14878                     {
14879                         RExC_parse++;
14880                         vFAIL("Unexpected '(' with no preceding operator");
14881                     }
14882                 }
14883
14884                 /* Stack the position of this undealt-with left paren */
14885                 fence = top_index + 1;
14886                 av_push(fence_stack, newSViv(fence));
14887                 break;
14888
14889             case '\\':
14890                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
14891                  * multi-char folds are allowed.  */
14892                 if (!regclass(pRExC_state, flagp,depth+1,
14893                               TRUE, /* means parse just the next thing */
14894                               FALSE, /* don't allow multi-char folds */
14895                               FALSE, /* don't silence non-portable warnings.  */
14896                               TRUE,  /* strict */
14897                               FALSE, /* Require return to be an ANYOF */
14898                               &current,
14899                               NULL))
14900                 {
14901                     FAIL2("panic: regclass returned NULL to handle_sets, "
14902                           "flags=%#"UVxf"", (UV) *flagp);
14903                 }
14904
14905                 /* regclass() will return with parsing just the \ sequence,
14906                  * leaving the parse pointer at the next thing to parse */
14907                 RExC_parse--;
14908                 goto handle_operand;
14909
14910             case '[':   /* Is a bracketed character class */
14911             {
14912                 /* See if this is a [:posix:] class. */
14913                 bool is_posix_class = (OOB_NAMEDCLASS
14914                             < handle_possible_posix(pRExC_state,
14915                                                 RExC_parse + 1,
14916                                                 NULL,
14917                                                 NULL,
14918                                                 TRUE /* checking only */));
14919                 /* If it is a posix class, leave the parse pointer at the '['
14920                  * to fool regclass() into thinking it is part of a
14921                  * '[[:posix:]]'. */
14922                 if (! is_posix_class) {
14923                     RExC_parse++;
14924                 }
14925
14926                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
14927                  * multi-char folds are allowed.  */
14928                 if (!regclass(pRExC_state, flagp,depth+1,
14929                                 is_posix_class, /* parse the whole char
14930                                                     class only if not a
14931                                                     posix class */
14932                                 FALSE, /* don't allow multi-char folds */
14933                                 TRUE, /* silence non-portable warnings. */
14934                                 TRUE, /* strict */
14935                                 FALSE, /* Require return to be an ANYOF */
14936                                 &current,
14937                                 NULL
14938                                 ))
14939                 {
14940                     FAIL2("panic: regclass returned NULL to handle_sets, "
14941                           "flags=%#"UVxf"", (UV) *flagp);
14942                 }
14943
14944                 /* function call leaves parse pointing to the ']', except if we
14945                  * faked it */
14946                 if (is_posix_class) {
14947                     RExC_parse--;
14948                 }
14949
14950                 goto handle_operand;
14951             }
14952
14953             case ']':
14954                 if (top_index >= 1) {
14955                     goto join_operators;
14956                 }
14957
14958                 /* Only a single operand on the stack: are done */
14959                 goto done;
14960
14961             case ')':
14962                 if (av_tindex_nomg(fence_stack) < 0) {
14963                     RExC_parse++;
14964                     vFAIL("Unexpected ')'");
14965                 }
14966
14967                  /* If at least two thing on the stack, treat this as an
14968                   * operator */
14969                 if (top_index - fence >= 1) {
14970                     goto join_operators;
14971                 }
14972
14973                 /* Here only a single thing on the fenced stack, and there is a
14974                  * fence.  Get rid of it */
14975                 fence_ptr = av_pop(fence_stack);
14976                 assert(fence_ptr);
14977                 fence = SvIV(fence_ptr) - 1;
14978                 SvREFCNT_dec_NN(fence_ptr);
14979                 fence_ptr = NULL;
14980
14981                 if (fence < 0) {
14982                     fence = 0;
14983                 }
14984
14985                 /* Having gotten rid of the fence, we pop the operand at the
14986                  * stack top and process it as a newly encountered operand */
14987                 current = av_pop(stack);
14988                 if (IS_OPERAND(current)) {
14989                     goto handle_operand;
14990                 }
14991
14992                 RExC_parse++;
14993                 goto bad_syntax;
14994
14995             case '&':
14996             case '|':
14997             case '+':
14998             case '-':
14999             case '^':
15000
15001                 /* These binary operators should have a left operand already
15002                  * parsed */
15003                 if (   top_index - fence < 0
15004                     || top_index - fence == 1
15005                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15006                     || ! IS_OPERAND(*top_ptr))
15007                 {
15008                     goto unexpected_binary;
15009                 }
15010
15011                 /* If only the one operand is on the part of the stack visible
15012                  * to us, we just place this operator in the proper position */
15013                 if (top_index - fence < 2) {
15014
15015                     /* Place the operator before the operand */
15016
15017                     SV* lhs = av_pop(stack);
15018                     av_push(stack, newSVuv(curchar));
15019                     av_push(stack, lhs);
15020                     break;
15021                 }
15022
15023                 /* But if there is something else on the stack, we need to
15024                  * process it before this new operator if and only if the
15025                  * stacked operation has equal or higher precedence than the
15026                  * new one */
15027
15028              join_operators:
15029
15030                 /* The operator on the stack is supposed to be below both its
15031                  * operands */
15032                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15033                     || IS_OPERAND(*stacked_ptr))
15034                 {
15035                     /* But if not, it's legal and indicates we are completely
15036                      * done if and only if we're currently processing a ']',
15037                      * which should be the final thing in the expression */
15038                     if (curchar == ']') {
15039                         goto done;
15040                     }
15041
15042                   unexpected_binary:
15043                     RExC_parse++;
15044                     vFAIL2("Unexpected binary operator '%c' with no "
15045                            "preceding operand", curchar);
15046                 }
15047                 stacked_operator = (char) SvUV(*stacked_ptr);
15048
15049                 if (regex_set_precedence(curchar)
15050                     > regex_set_precedence(stacked_operator))
15051                 {
15052                     /* Here, the new operator has higher precedence than the
15053                      * stacked one.  This means we need to add the new one to
15054                      * the stack to await its rhs operand (and maybe more
15055                      * stuff).  We put it before the lhs operand, leaving
15056                      * untouched the stacked operator and everything below it
15057                      * */
15058                     lhs = av_pop(stack);
15059                     assert(IS_OPERAND(lhs));
15060
15061                     av_push(stack, newSVuv(curchar));
15062                     av_push(stack, lhs);
15063                     break;
15064                 }
15065
15066                 /* Here, the new operator has equal or lower precedence than
15067                  * what's already there.  This means the operation already
15068                  * there should be performed now, before the new one. */
15069
15070                 rhs = av_pop(stack);
15071                 if (! IS_OPERAND(rhs)) {
15072
15073                     /* This can happen when a ! is not followed by an operand,
15074                      * like in /(?[\t &!])/ */
15075                     goto bad_syntax;
15076                 }
15077
15078                 lhs = av_pop(stack);
15079
15080                 if (! IS_OPERAND(lhs)) {
15081
15082                     /* This can happen when there is an empty (), like in
15083                      * /(?[[0]+()+])/ */
15084                     goto bad_syntax;
15085                 }
15086
15087                 switch (stacked_operator) {
15088                     case '&':
15089                         _invlist_intersection(lhs, rhs, &rhs);
15090                         break;
15091
15092                     case '|':
15093                     case '+':
15094                         _invlist_union(lhs, rhs, &rhs);
15095                         break;
15096
15097                     case '-':
15098                         _invlist_subtract(lhs, rhs, &rhs);
15099                         break;
15100
15101                     case '^':   /* The union minus the intersection */
15102                     {
15103                         SV* i = NULL;
15104                         SV* u = NULL;
15105                         SV* element;
15106
15107                         _invlist_union(lhs, rhs, &u);
15108                         _invlist_intersection(lhs, rhs, &i);
15109                         /* _invlist_subtract will overwrite rhs
15110                             without freeing what it already contains */
15111                         element = rhs;
15112                         _invlist_subtract(u, i, &rhs);
15113                         SvREFCNT_dec_NN(i);
15114                         SvREFCNT_dec_NN(u);
15115                         SvREFCNT_dec_NN(element);
15116                         break;
15117                     }
15118                 }
15119                 SvREFCNT_dec(lhs);
15120
15121                 /* Here, the higher precedence operation has been done, and the
15122                  * result is in 'rhs'.  We overwrite the stacked operator with
15123                  * the result.  Then we redo this code to either push the new
15124                  * operator onto the stack or perform any higher precedence
15125                  * stacked operation */
15126                 only_to_avoid_leaks = av_pop(stack);
15127                 SvREFCNT_dec(only_to_avoid_leaks);
15128                 av_push(stack, rhs);
15129                 goto redo_curchar;
15130
15131             case '!':   /* Highest priority, right associative */
15132
15133                 /* If what's already at the top of the stack is another '!",
15134                  * they just cancel each other out */
15135                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15136                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15137                 {
15138                     only_to_avoid_leaks = av_pop(stack);
15139                     SvREFCNT_dec(only_to_avoid_leaks);
15140                 }
15141                 else { /* Otherwise, since it's right associative, just push
15142                           onto the stack */
15143                     av_push(stack, newSVuv(curchar));
15144                 }
15145                 break;
15146
15147             default:
15148                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15149                 vFAIL("Unexpected character");
15150
15151           handle_operand:
15152
15153             /* Here 'current' is the operand.  If something is already on the
15154              * stack, we have to check if it is a !.  But first, the code above
15155              * may have altered the stack in the time since we earlier set
15156              * 'top_index'.  */
15157
15158             top_index = av_tindex_nomg(stack);
15159             if (top_index - fence >= 0) {
15160                 /* If the top entry on the stack is an operator, it had better
15161                  * be a '!', otherwise the entry below the top operand should
15162                  * be an operator */
15163                 top_ptr = av_fetch(stack, top_index, FALSE);
15164                 assert(top_ptr);
15165                 if (IS_OPERATOR(*top_ptr)) {
15166
15167                     /* The only permissible operator at the top of the stack is
15168                      * '!', which is applied immediately to this operand. */
15169                     curchar = (char) SvUV(*top_ptr);
15170                     if (curchar != '!') {
15171                         SvREFCNT_dec(current);
15172                         vFAIL2("Unexpected binary operator '%c' with no "
15173                                 "preceding operand", curchar);
15174                     }
15175
15176                     _invlist_invert(current);
15177
15178                     only_to_avoid_leaks = av_pop(stack);
15179                     SvREFCNT_dec(only_to_avoid_leaks);
15180
15181                     /* And we redo with the inverted operand.  This allows
15182                      * handling multiple ! in a row */
15183                     goto handle_operand;
15184                 }
15185                           /* Single operand is ok only for the non-binary ')'
15186                            * operator */
15187                 else if ((top_index - fence == 0 && curchar != ')')
15188                          || (top_index - fence > 0
15189                              && (! (stacked_ptr = av_fetch(stack,
15190                                                            top_index - 1,
15191                                                            FALSE))
15192                                  || IS_OPERAND(*stacked_ptr))))
15193                 {
15194                     SvREFCNT_dec(current);
15195                     vFAIL("Operand with no preceding operator");
15196                 }
15197             }
15198
15199             /* Here there was nothing on the stack or the top element was
15200              * another operand.  Just add this new one */
15201             av_push(stack, current);
15202
15203         } /* End of switch on next parse token */
15204
15205         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15206     } /* End of loop parsing through the construct */
15207
15208   done:
15209     if (av_tindex_nomg(fence_stack) >= 0) {
15210         vFAIL("Unmatched (");
15211     }
15212
15213     if (av_tindex_nomg(stack) < 0   /* Was empty */
15214         || ((final = av_pop(stack)) == NULL)
15215         || ! IS_OPERAND(final)
15216         || SvTYPE(final) != SVt_INVLIST
15217         || av_tindex_nomg(stack) >= 0)  /* More left on stack */
15218     {
15219       bad_syntax:
15220         SvREFCNT_dec(final);
15221         vFAIL("Incomplete expression within '(?[ ])'");
15222     }
15223
15224     /* Here, 'final' is the resultant inversion list from evaluating the
15225      * expression.  Return it if so requested */
15226     if (return_invlist) {
15227         *return_invlist = final;
15228         return END;
15229     }
15230
15231     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15232      * expecting a string of ranges and individual code points */
15233     invlist_iterinit(final);
15234     result_string = newSVpvs("");
15235     while (invlist_iternext(final, &start, &end)) {
15236         if (start == end) {
15237             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
15238         }
15239         else {
15240             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
15241                                                      start,          end);
15242         }
15243     }
15244
15245     /* About to generate an ANYOF (or similar) node from the inversion list we
15246      * have calculated */
15247     save_parse = RExC_parse;
15248     RExC_parse = SvPV(result_string, len);
15249     save_end = RExC_end;
15250     RExC_end = RExC_parse + len;
15251
15252     /* We turn off folding around the call, as the class we have constructed
15253      * already has all folding taken into consideration, and we don't want
15254      * regclass() to add to that */
15255     RExC_flags &= ~RXf_PMf_FOLD;
15256     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15257      * folds are allowed.  */
15258     node = regclass(pRExC_state, flagp,depth+1,
15259                     FALSE, /* means parse the whole char class */
15260                     FALSE, /* don't allow multi-char folds */
15261                     TRUE, /* silence non-portable warnings.  The above may very
15262                              well have generated non-portable code points, but
15263                              they're valid on this machine */
15264                     FALSE, /* similarly, no need for strict */
15265                     FALSE, /* Require return to be an ANYOF */
15266                     NULL,
15267                     NULL
15268                 );
15269     if (!node)
15270         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
15271                     PTR2UV(flagp));
15272
15273     /* Fix up the node type if we are in locale.  (We have pretended we are
15274      * under /u for the purposes of regclass(), as this construct will only
15275      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15276      * as to cause any warnings about bad locales to be output in regexec.c),
15277      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15278      * reason we above forbid optimization into something other than an ANYOF
15279      * node is simply to minimize the number of code changes in regexec.c.
15280      * Otherwise we would have to create new EXACTish node types and deal with
15281      * them.  This decision could be revisited should this construct become
15282      * popular.
15283      *
15284      * (One might think we could look at the resulting ANYOF node and suppress
15285      * the flag if everything is above 255, as those would be UTF-8 only,
15286      * but this isn't true, as the components that led to that result could
15287      * have been locale-affected, and just happen to cancel each other out
15288      * under UTF-8 locales.) */
15289     if (in_locale) {
15290         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15291
15292         assert(OP(node) == ANYOF);
15293
15294         OP(node) = ANYOFL;
15295         ANYOF_FLAGS(node)
15296                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
15297     }
15298
15299     if (save_fold) {
15300         RExC_flags |= RXf_PMf_FOLD;
15301     }
15302
15303     RExC_parse = save_parse + 1;
15304     RExC_end = save_end;
15305     SvREFCNT_dec_NN(final);
15306     SvREFCNT_dec_NN(result_string);
15307
15308     nextchar(pRExC_state);
15309     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
15310     return node;
15311 }
15312 #undef IS_OPERATOR
15313 #undef IS_OPERAND
15314
15315 STATIC void
15316 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
15317 {
15318     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
15319      * innocent-looking character class, like /[ks]/i won't have to go out to
15320      * disk to find the possible matches.
15321      *
15322      * This should be called only for a Latin1-range code points, cp, which is
15323      * known to be involved in a simple fold with other code points above
15324      * Latin1.  It would give false results if /aa has been specified.
15325      * Multi-char folds are outside the scope of this, and must be handled
15326      * specially.
15327      *
15328      * XXX It would be better to generate these via regen, in case a new
15329      * version of the Unicode standard adds new mappings, though that is not
15330      * really likely, and may be caught by the default: case of the switch
15331      * below. */
15332
15333     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
15334
15335     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
15336
15337     switch (cp) {
15338         case 'k':
15339         case 'K':
15340           *invlist =
15341              add_cp_to_invlist(*invlist, KELVIN_SIGN);
15342             break;
15343         case 's':
15344         case 'S':
15345           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
15346             break;
15347         case MICRO_SIGN:
15348           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
15349           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
15350             break;
15351         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
15352         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
15353           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
15354             break;
15355         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
15356           *invlist = add_cp_to_invlist(*invlist,
15357                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
15358             break;
15359
15360 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
15361
15362         case LATIN_SMALL_LETTER_SHARP_S:
15363           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
15364             break;
15365
15366 #endif
15367
15368 #if    UNICODE_MAJOR_VERSION < 3                                        \
15369    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
15370
15371         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
15372          * U+0131.  */
15373         case 'i':
15374         case 'I':
15375           *invlist =
15376              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
15377 #   if UNICODE_DOT_DOT_VERSION == 1
15378           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
15379 #   endif
15380             break;
15381 #endif
15382
15383         default:
15384             /* Use deprecated warning to increase the chances of this being
15385              * output */
15386             if (PASS2) {
15387                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
15388             }
15389             break;
15390     }
15391 }
15392
15393 STATIC void
15394 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
15395 {
15396     /* If the final parameter is NULL, output the elements of the array given
15397      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
15398      * pushed onto it, (creating if necessary) */
15399
15400     SV * msg;
15401     const bool first_is_fatal =  ! return_posix_warnings
15402                                 && ckDEAD(packWARN(WARN_REGEXP));
15403
15404     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
15405
15406     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
15407         if (return_posix_warnings) {
15408             if (! *return_posix_warnings) { /* mortalize to not leak if
15409                                                warnings are fatal */
15410                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
15411             }
15412             av_push(*return_posix_warnings, msg);
15413         }
15414         else {
15415             if (first_is_fatal) {           /* Avoid leaking this */
15416                 av_undef(posix_warnings);   /* This isn't necessary if the
15417                                                array is mortal, but is a
15418                                                fail-safe */
15419                 (void) sv_2mortal(msg);
15420                 if (PASS2) {
15421                     SAVEFREESV(RExC_rx_sv);
15422                 }
15423             }
15424             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
15425             SvREFCNT_dec_NN(msg);
15426         }
15427     }
15428 }
15429
15430 STATIC AV *
15431 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
15432 {
15433     /* This adds the string scalar <multi_string> to the array
15434      * <multi_char_matches>.  <multi_string> is known to have exactly
15435      * <cp_count> code points in it.  This is used when constructing a
15436      * bracketed character class and we find something that needs to match more
15437      * than a single character.
15438      *
15439      * <multi_char_matches> is actually an array of arrays.  Each top-level
15440      * element is an array that contains all the strings known so far that are
15441      * the same length.  And that length (in number of code points) is the same
15442      * as the index of the top-level array.  Hence, the [2] element is an
15443      * array, each element thereof is a string containing TWO code points;
15444      * while element [3] is for strings of THREE characters, and so on.  Since
15445      * this is for multi-char strings there can never be a [0] nor [1] element.
15446      *
15447      * When we rewrite the character class below, we will do so such that the
15448      * longest strings are written first, so that it prefers the longest
15449      * matching strings first.  This is done even if it turns out that any
15450      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
15451      * Christiansen has agreed that this is ok.  This makes the test for the
15452      * ligature 'ffi' come before the test for 'ff', for example */
15453
15454     AV* this_array;
15455     AV** this_array_ptr;
15456
15457     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
15458
15459     if (! multi_char_matches) {
15460         multi_char_matches = newAV();
15461     }
15462
15463     if (av_exists(multi_char_matches, cp_count)) {
15464         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
15465         this_array = *this_array_ptr;
15466     }
15467     else {
15468         this_array = newAV();
15469         av_store(multi_char_matches, cp_count,
15470                  (SV*) this_array);
15471     }
15472     av_push(this_array, multi_string);
15473
15474     return multi_char_matches;
15475 }
15476
15477 /* The names of properties whose definitions are not known at compile time are
15478  * stored in this SV, after a constant heading.  So if the length has been
15479  * changed since initialization, then there is a run-time definition. */
15480 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
15481                                         (SvCUR(listsv) != initial_listsv_len)
15482
15483 /* There is a restricted set of white space characters that are legal when
15484  * ignoring white space in a bracketed character class.  This generates the
15485  * code to skip them.
15486  *
15487  * There is a line below that uses the same white space criteria but is outside
15488  * this macro.  Both here and there must use the same definition */
15489 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
15490     STMT_START {                                                        \
15491         if (do_skip) {                                                  \
15492             while (isBLANK_A(UCHARAT(p)))                               \
15493             {                                                           \
15494                 p++;                                                    \
15495             }                                                           \
15496         }                                                               \
15497     } STMT_END
15498
15499 STATIC regnode *
15500 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
15501                  const bool stop_at_1,  /* Just parse the next thing, don't
15502                                            look for a full character class */
15503                  bool allow_multi_folds,
15504                  const bool silence_non_portable,   /* Don't output warnings
15505                                                        about too large
15506                                                        characters */
15507                  const bool strict,
15508                  bool optimizable,                  /* ? Allow a non-ANYOF return
15509                                                        node */
15510                  SV** ret_invlist, /* Return an inversion list, not a node */
15511                  AV** return_posix_warnings
15512           )
15513 {
15514     /* parse a bracketed class specification.  Most of these will produce an
15515      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
15516      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
15517      * under /i with multi-character folds: it will be rewritten following the
15518      * paradigm of this example, where the <multi-fold>s are characters which
15519      * fold to multiple character sequences:
15520      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
15521      * gets effectively rewritten as:
15522      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
15523      * reg() gets called (recursively) on the rewritten version, and this
15524      * function will return what it constructs.  (Actually the <multi-fold>s
15525      * aren't physically removed from the [abcdefghi], it's just that they are
15526      * ignored in the recursion by means of a flag:
15527      * <RExC_in_multi_char_class>.)
15528      *
15529      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
15530      * characters, with the corresponding bit set if that character is in the
15531      * list.  For characters above this, a range list or swash is used.  There
15532      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
15533      * determinable at compile time
15534      *
15535      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
15536      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
15537      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
15538      */
15539
15540     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
15541     IV range = 0;
15542     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
15543     regnode *ret;
15544     STRLEN numlen;
15545     int namedclass = OOB_NAMEDCLASS;
15546     char *rangebegin = NULL;
15547     bool need_class = 0;
15548     SV *listsv = NULL;
15549     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
15550                                       than just initialized.  */
15551     SV* properties = NULL;    /* Code points that match \p{} \P{} */
15552     SV* posixes = NULL;     /* Code points that match classes like [:word:],
15553                                extended beyond the Latin1 range.  These have to
15554                                be kept separate from other code points for much
15555                                of this function because their handling  is
15556                                different under /i, and for most classes under
15557                                /d as well */
15558     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
15559                                separate for a while from the non-complemented
15560                                versions because of complications with /d
15561                                matching */
15562     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
15563                                   treated more simply than the general case,
15564                                   leading to less compilation and execution
15565                                   work */
15566     UV element_count = 0;   /* Number of distinct elements in the class.
15567                                Optimizations may be possible if this is tiny */
15568     AV * multi_char_matches = NULL; /* Code points that fold to more than one
15569                                        character; used under /i */
15570     UV n;
15571     char * stop_ptr = RExC_end;    /* where to stop parsing */
15572     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
15573                                                    space? */
15574
15575     /* Unicode properties are stored in a swash; this holds the current one
15576      * being parsed.  If this swash is the only above-latin1 component of the
15577      * character class, an optimization is to pass it directly on to the
15578      * execution engine.  Otherwise, it is set to NULL to indicate that there
15579      * are other things in the class that have to be dealt with at execution
15580      * time */
15581     SV* swash = NULL;           /* Code points that match \p{} \P{} */
15582
15583     /* Set if a component of this character class is user-defined; just passed
15584      * on to the engine */
15585     bool has_user_defined_property = FALSE;
15586
15587     /* inversion list of code points this node matches only when the target
15588      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
15589      * /d) */
15590     SV* has_upper_latin1_only_utf8_matches = NULL;
15591
15592     /* Inversion list of code points this node matches regardless of things
15593      * like locale, folding, utf8ness of the target string */
15594     SV* cp_list = NULL;
15595
15596     /* Like cp_list, but code points on this list need to be checked for things
15597      * that fold to/from them under /i */
15598     SV* cp_foldable_list = NULL;
15599
15600     /* Like cp_list, but code points on this list are valid only when the
15601      * runtime locale is UTF-8 */
15602     SV* only_utf8_locale_list = NULL;
15603
15604     /* In a range, if one of the endpoints is non-character-set portable,
15605      * meaning that it hard-codes a code point that may mean a different
15606      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
15607      * mnemonic '\t' which each mean the same character no matter which
15608      * character set the platform is on. */
15609     unsigned int non_portable_endpoint = 0;
15610
15611     /* Is the range unicode? which means on a platform that isn't 1-1 native
15612      * to Unicode (i.e. non-ASCII), each code point in it should be considered
15613      * to be a Unicode value.  */
15614     bool unicode_range = FALSE;
15615     bool invert = FALSE;    /* Is this class to be complemented */
15616
15617     bool warn_super = ALWAYS_WARN_SUPER;
15618
15619     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
15620         case we need to change the emitted regop to an EXACT. */
15621     const char * orig_parse = RExC_parse;
15622     const SSize_t orig_size = RExC_size;
15623     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
15624
15625     /* This variable is used to mark where the end in the input is of something
15626      * that looks like a POSIX construct but isn't.  During the parse, when
15627      * something looks like it could be such a construct is encountered, it is
15628      * checked for being one, but not if we've already checked this area of the
15629      * input.  Only after this position is reached do we check again */
15630     char *not_posix_region_end = RExC_parse - 1;
15631
15632     AV* posix_warnings = NULL;
15633     const bool do_posix_warnings =     return_posix_warnings
15634                                    || (PASS2 && ckWARN(WARN_REGEXP));
15635
15636     GET_RE_DEBUG_FLAGS_DECL;
15637
15638     PERL_ARGS_ASSERT_REGCLASS;
15639 #ifndef DEBUGGING
15640     PERL_UNUSED_ARG(depth);
15641 #endif
15642
15643     DEBUG_PARSE("clas");
15644
15645 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
15646     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
15647                                    && UNICODE_DOT_DOT_VERSION == 0)
15648     allow_multi_folds = FALSE;
15649 #endif
15650
15651     /* Assume we are going to generate an ANYOF node. */
15652     ret = reganode(pRExC_state,
15653                    (LOC)
15654                     ? ANYOFL
15655                     : ANYOF,
15656                    0);
15657
15658     if (SIZE_ONLY) {
15659         RExC_size += ANYOF_SKIP;
15660         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
15661     }
15662     else {
15663         ANYOF_FLAGS(ret) = 0;
15664
15665         RExC_emit += ANYOF_SKIP;
15666         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
15667         initial_listsv_len = SvCUR(listsv);
15668         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
15669     }
15670
15671     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15672
15673     assert(RExC_parse <= RExC_end);
15674
15675     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
15676         RExC_parse++;
15677         invert = TRUE;
15678         allow_multi_folds = FALSE;
15679         MARK_NAUGHTY(1);
15680         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15681     }
15682
15683     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
15684     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
15685         int maybe_class = handle_possible_posix(pRExC_state,
15686                                                 RExC_parse,
15687                                                 &not_posix_region_end,
15688                                                 NULL,
15689                                                 TRUE /* checking only */);
15690         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
15691             SAVEFREESV(RExC_rx_sv);
15692             ckWARN4reg(not_posix_region_end,
15693                     "POSIX syntax [%c %c] belongs inside character classes%s",
15694                     *RExC_parse, *RExC_parse,
15695                     (maybe_class == OOB_NAMEDCLASS)
15696                     ? ((POSIXCC_NOTYET(*RExC_parse))
15697                         ? " (but this one isn't implemented)"
15698                         : " (but this one isn't fully valid)")
15699                     : ""
15700                     );
15701             (void)ReREFCNT_inc(RExC_rx_sv);
15702         }
15703     }
15704
15705     /* If the caller wants us to just parse a single element, accomplish this
15706      * by faking the loop ending condition */
15707     if (stop_at_1 && RExC_end > RExC_parse) {
15708         stop_ptr = RExC_parse + 1;
15709     }
15710
15711     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
15712     if (UCHARAT(RExC_parse) == ']')
15713         goto charclassloop;
15714
15715     while (1) {
15716
15717         if (   posix_warnings
15718             && av_tindex_nomg(posix_warnings) >= 0
15719             && RExC_parse > not_posix_region_end)
15720         {
15721             /* Warnings about posix class issues are considered tentative until
15722              * we are far enough along in the parse that we can no longer
15723              * change our mind, at which point we either output them or add
15724              * them, if it has so specified, to what gets returned to the
15725              * caller.  This is done each time through the loop so that a later
15726              * class won't zap them before they have been dealt with. */
15727             output_or_return_posix_warnings(pRExC_state, posix_warnings,
15728                                             return_posix_warnings);
15729         }
15730
15731         if  (RExC_parse >= stop_ptr) {
15732             break;
15733         }
15734
15735         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15736
15737         if  (UCHARAT(RExC_parse) == ']') {
15738             break;
15739         }
15740
15741       charclassloop:
15742
15743         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
15744         save_value = value;
15745         save_prevvalue = prevvalue;
15746
15747         if (!range) {
15748             rangebegin = RExC_parse;
15749             element_count++;
15750             non_portable_endpoint = 0;
15751         }
15752         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
15753             value = utf8n_to_uvchr((U8*)RExC_parse,
15754                                    RExC_end - RExC_parse,
15755                                    &numlen, UTF8_ALLOW_DEFAULT);
15756             RExC_parse += numlen;
15757         }
15758         else
15759             value = UCHARAT(RExC_parse++);
15760
15761         if (value == '[') {
15762             char * posix_class_end;
15763             namedclass = handle_possible_posix(pRExC_state,
15764                                                RExC_parse,
15765                                                &posix_class_end,
15766                                                do_posix_warnings ? &posix_warnings : NULL,
15767                                                FALSE    /* die if error */);
15768             if (namedclass > OOB_NAMEDCLASS) {
15769
15770                 /* If there was an earlier attempt to parse this particular
15771                  * posix class, and it failed, it was a false alarm, as this
15772                  * successful one proves */
15773                 if (   posix_warnings
15774                     && av_tindex_nomg(posix_warnings) >= 0
15775                     && not_posix_region_end >= RExC_parse
15776                     && not_posix_region_end <= posix_class_end)
15777                 {
15778                     av_undef(posix_warnings);
15779                 }
15780
15781                 RExC_parse = posix_class_end;
15782             }
15783             else if (namedclass == OOB_NAMEDCLASS) {
15784                 not_posix_region_end = posix_class_end;
15785             }
15786             else {
15787                 namedclass = OOB_NAMEDCLASS;
15788             }
15789         }
15790         else if (   RExC_parse - 1 > not_posix_region_end
15791                  && MAYBE_POSIXCC(value))
15792         {
15793             (void) handle_possible_posix(
15794                         pRExC_state,
15795                         RExC_parse - 1,  /* -1 because parse has already been
15796                                             advanced */
15797                         &not_posix_region_end,
15798                         do_posix_warnings ? &posix_warnings : NULL,
15799                         TRUE /* checking only */);
15800         }
15801         else if (value == '\\') {
15802             /* Is a backslash; get the code point of the char after it */
15803
15804             if (RExC_parse >= RExC_end) {
15805                 vFAIL("Unmatched [");
15806             }
15807
15808             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
15809                 value = utf8n_to_uvchr((U8*)RExC_parse,
15810                                    RExC_end - RExC_parse,
15811                                    &numlen, UTF8_ALLOW_DEFAULT);
15812                 RExC_parse += numlen;
15813             }
15814             else
15815                 value = UCHARAT(RExC_parse++);
15816
15817             /* Some compilers cannot handle switching on 64-bit integer
15818              * values, therefore value cannot be an UV.  Yes, this will
15819              * be a problem later if we want switch on Unicode.
15820              * A similar issue a little bit later when switching on
15821              * namedclass. --jhi */
15822
15823             /* If the \ is escaping white space when white space is being
15824              * skipped, it means that that white space is wanted literally, and
15825              * is already in 'value'.  Otherwise, need to translate the escape
15826              * into what it signifies. */
15827             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
15828
15829             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
15830             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
15831             case 's':   namedclass = ANYOF_SPACE;       break;
15832             case 'S':   namedclass = ANYOF_NSPACE;      break;
15833             case 'd':   namedclass = ANYOF_DIGIT;       break;
15834             case 'D':   namedclass = ANYOF_NDIGIT;      break;
15835             case 'v':   namedclass = ANYOF_VERTWS;      break;
15836             case 'V':   namedclass = ANYOF_NVERTWS;     break;
15837             case 'h':   namedclass = ANYOF_HORIZWS;     break;
15838             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
15839             case 'N':  /* Handle \N{NAME} in class */
15840                 {
15841                     const char * const backslash_N_beg = RExC_parse - 2;
15842                     int cp_count;
15843
15844                     if (! grok_bslash_N(pRExC_state,
15845                                         NULL,      /* No regnode */
15846                                         &value,    /* Yes single value */
15847                                         &cp_count, /* Multiple code pt count */
15848                                         flagp,
15849                                         strict,
15850                                         depth)
15851                     ) {
15852
15853                         if (*flagp & NEED_UTF8)
15854                             FAIL("panic: grok_bslash_N set NEED_UTF8");
15855                         if (*flagp & RESTART_PASS1)
15856                             return NULL;
15857
15858                         if (cp_count < 0) {
15859                             vFAIL("\\N in a character class must be a named character: \\N{...}");
15860                         }
15861                         else if (cp_count == 0) {
15862                             if (PASS2) {
15863                                 ckWARNreg(RExC_parse,
15864                                         "Ignoring zero length \\N{} in character class");
15865                             }
15866                         }
15867                         else { /* cp_count > 1 */
15868                             if (! RExC_in_multi_char_class) {
15869                                 if (invert || range || *RExC_parse == '-') {
15870                                     if (strict) {
15871                                         RExC_parse--;
15872                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
15873                                     }
15874                                     else if (PASS2) {
15875                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
15876                                     }
15877                                     break; /* <value> contains the first code
15878                                               point. Drop out of the switch to
15879                                               process it */
15880                                 }
15881                                 else {
15882                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
15883                                                  RExC_parse - backslash_N_beg);
15884                                     multi_char_matches
15885                                         = add_multi_match(multi_char_matches,
15886                                                           multi_char_N,
15887                                                           cp_count);
15888                                 }
15889                             }
15890                         } /* End of cp_count != 1 */
15891
15892                         /* This element should not be processed further in this
15893                          * class */
15894                         element_count--;
15895                         value = save_value;
15896                         prevvalue = save_prevvalue;
15897                         continue;   /* Back to top of loop to get next char */
15898                     }
15899
15900                     /* Here, is a single code point, and <value> contains it */
15901                     unicode_range = TRUE;   /* \N{} are Unicode */
15902                 }
15903                 break;
15904             case 'p':
15905             case 'P':
15906                 {
15907                 char *e;
15908
15909                 /* We will handle any undefined properties ourselves */
15910                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
15911                                        /* And we actually would prefer to get
15912                                         * the straight inversion list of the
15913                                         * swash, since we will be accessing it
15914                                         * anyway, to save a little time */
15915                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
15916
15917                 if (RExC_parse >= RExC_end)
15918                     vFAIL2("Empty \\%c", (U8)value);
15919                 if (*RExC_parse == '{') {
15920                     const U8 c = (U8)value;
15921                     e = strchr(RExC_parse, '}');
15922                     if (!e) {
15923                         RExC_parse++;
15924                         vFAIL2("Missing right brace on \\%c{}", c);
15925                     }
15926
15927                     RExC_parse++;
15928                     while (isSPACE(*RExC_parse)) {
15929                          RExC_parse++;
15930                     }
15931
15932                     if (UCHARAT(RExC_parse) == '^') {
15933
15934                         /* toggle.  (The rhs xor gets the single bit that
15935                          * differs between P and p; the other xor inverts just
15936                          * that bit) */
15937                         value ^= 'P' ^ 'p';
15938
15939                         RExC_parse++;
15940                         while (isSPACE(*RExC_parse)) {
15941                             RExC_parse++;
15942                         }
15943                     }
15944
15945                     if (e == RExC_parse)
15946                         vFAIL2("Empty \\%c{}", c);
15947
15948                     n = e - RExC_parse;
15949                     while (isSPACE(*(RExC_parse + n - 1)))
15950                         n--;
15951                 }   /* The \p isn't immediately followed by a '{' */
15952                 else if (! isALPHA(*RExC_parse)) {
15953                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15954                     vFAIL2("Character following \\%c must be '{' or a "
15955                            "single-character Unicode property name",
15956                            (U8) value);
15957                 }
15958                 else {
15959                     e = RExC_parse;
15960                     n = 1;
15961                 }
15962                 if (!SIZE_ONLY) {
15963                     SV* invlist;
15964                     char* name;
15965                     char* base_name;    /* name after any packages are stripped */
15966                     char* lookup_name = NULL;
15967                     const char * const colon_colon = "::";
15968
15969                     /* Try to get the definition of the property into
15970                      * <invlist>.  If /i is in effect, the effective property
15971                      * will have its name be <__NAME_i>.  The design is
15972                      * discussed in commit
15973                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
15974                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
15975                     SAVEFREEPV(name);
15976                     if (FOLD) {
15977                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
15978
15979                         /* The function call just below that uses this can fail
15980                          * to return, leaking memory if we don't do this */
15981                         SAVEFREEPV(lookup_name);
15982                     }
15983
15984                     /* Look up the property name, and get its swash and
15985                      * inversion list, if the property is found  */
15986                     SvREFCNT_dec(swash); /* Free any left-overs */
15987                     swash = _core_swash_init("utf8",
15988                                              (lookup_name)
15989                                               ? lookup_name
15990                                               : name,
15991                                              &PL_sv_undef,
15992                                              1, /* binary */
15993                                              0, /* not tr/// */
15994                                              NULL, /* No inversion list */
15995                                              &swash_init_flags
15996                                             );
15997                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
15998                         HV* curpkg = (IN_PERL_COMPILETIME)
15999                                       ? PL_curstash
16000                                       : CopSTASH(PL_curcop);
16001                         UV final_n = n;
16002                         bool has_pkg;
16003
16004                         if (swash) {    /* Got a swash but no inversion list.
16005                                            Something is likely wrong that will
16006                                            be sorted-out later */
16007                             SvREFCNT_dec_NN(swash);
16008                             swash = NULL;
16009                         }
16010
16011                         /* Here didn't find it.  It could be a an error (like a
16012                          * typo) in specifying a Unicode property, or it could
16013                          * be a user-defined property that will be available at
16014                          * run-time.  The names of these must begin with 'In'
16015                          * or 'Is' (after any packages are stripped off).  So
16016                          * if not one of those, or if we accept only
16017                          * compile-time properties, is an error; otherwise add
16018                          * it to the list for run-time look up. */
16019                         if ((base_name = rninstr(name, name + n,
16020                                                  colon_colon, colon_colon + 2)))
16021                         { /* Has ::.  We know this must be a user-defined
16022                              property */
16023                             base_name += 2;
16024                             final_n -= base_name - name;
16025                             has_pkg = TRUE;
16026                         }
16027                         else {
16028                             base_name = name;
16029                             has_pkg = FALSE;
16030                         }
16031
16032                         if (   final_n < 3
16033                             || base_name[0] != 'I'
16034                             || (base_name[1] != 's' && base_name[1] != 'n')
16035                             || ret_invlist)
16036                         {
16037                             const char * const msg
16038                                 = (has_pkg)
16039                                   ? "Illegal user-defined property name"
16040                                   : "Can't find Unicode property definition";
16041                             RExC_parse = e + 1;
16042
16043                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16044                             vFAIL3utf8f("%s \"%"UTF8f"\"",
16045                                 msg, UTF8fARG(UTF, n, name));
16046                         }
16047
16048                         /* If the property name doesn't already have a package
16049                          * name, add the current one to it so that it can be
16050                          * referred to outside it. [perl #121777] */
16051                         if (! has_pkg && curpkg) {
16052                             char* pkgname = HvNAME(curpkg);
16053                             if (strNE(pkgname, "main")) {
16054                                 char* full_name = Perl_form(aTHX_
16055                                                             "%s::%s",
16056                                                             pkgname,
16057                                                             name);
16058                                 n = strlen(full_name);
16059                                 name = savepvn(full_name, n);
16060                                 SAVEFREEPV(name);
16061                             }
16062                         }
16063                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%"UTF8f"%s\n",
16064                                         (value == 'p' ? '+' : '!'),
16065                                         (FOLD) ? "__" : "",
16066                                         UTF8fARG(UTF, n, name),
16067                                         (FOLD) ? "_i" : "");
16068                         has_user_defined_property = TRUE;
16069                         optimizable = FALSE;    /* Will have to leave this an
16070                                                    ANYOF node */
16071
16072                         /* We don't know yet what this matches, so have to flag
16073                          * it */
16074                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16075                     }
16076                     else {
16077
16078                         /* Here, did get the swash and its inversion list.  If
16079                          * the swash is from a user-defined property, then this
16080                          * whole character class should be regarded as such */
16081                         if (swash_init_flags
16082                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16083                         {
16084                             has_user_defined_property = TRUE;
16085                         }
16086                         else if
16087                             /* We warn on matching an above-Unicode code point
16088                              * if the match would return true, except don't
16089                              * warn for \p{All}, which has exactly one element
16090                              * = 0 */
16091                             (_invlist_contains_cp(invlist, 0x110000)
16092                                 && (! (_invlist_len(invlist) == 1
16093                                        && *invlist_array(invlist) == 0)))
16094                         {
16095                             warn_super = TRUE;
16096                         }
16097
16098
16099                         /* Invert if asking for the complement */
16100                         if (value == 'P') {
16101                             _invlist_union_complement_2nd(properties,
16102                                                           invlist,
16103                                                           &properties);
16104
16105                             /* The swash can't be used as-is, because we've
16106                              * inverted things; delay removing it to here after
16107                              * have copied its invlist above */
16108                             SvREFCNT_dec_NN(swash);
16109                             swash = NULL;
16110                         }
16111                         else {
16112                             _invlist_union(properties, invlist, &properties);
16113                         }
16114                     }
16115                 }
16116                 RExC_parse = e + 1;
16117                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16118                                                 named */
16119
16120                 /* \p means they want Unicode semantics */
16121                 REQUIRE_UNI_RULES(flagp, NULL);
16122                 }
16123                 break;
16124             case 'n':   value = '\n';                   break;
16125             case 'r':   value = '\r';                   break;
16126             case 't':   value = '\t';                   break;
16127             case 'f':   value = '\f';                   break;
16128             case 'b':   value = '\b';                   break;
16129             case 'e':   value = ESC_NATIVE;             break;
16130             case 'a':   value = '\a';                   break;
16131             case 'o':
16132                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16133                 {
16134                     const char* error_msg;
16135                     bool valid = grok_bslash_o(&RExC_parse,
16136                                                &value,
16137                                                &error_msg,
16138                                                PASS2,   /* warnings only in
16139                                                            pass 2 */
16140                                                strict,
16141                                                silence_non_portable,
16142                                                UTF);
16143                     if (! valid) {
16144                         vFAIL(error_msg);
16145                     }
16146                 }
16147                 non_portable_endpoint++;
16148                 if (IN_ENCODING && value < 0x100) {
16149                     goto recode_encoding;
16150                 }
16151                 break;
16152             case 'x':
16153                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16154                 {
16155                     const char* error_msg;
16156                     bool valid = grok_bslash_x(&RExC_parse,
16157                                                &value,
16158                                                &error_msg,
16159                                                PASS2, /* Output warnings */
16160                                                strict,
16161                                                silence_non_portable,
16162                                                UTF);
16163                     if (! valid) {
16164                         vFAIL(error_msg);
16165                     }
16166                 }
16167                 non_portable_endpoint++;
16168                 if (IN_ENCODING && value < 0x100)
16169                     goto recode_encoding;
16170                 break;
16171             case 'c':
16172                 value = grok_bslash_c(*RExC_parse++, PASS2);
16173                 non_portable_endpoint++;
16174                 break;
16175             case '0': case '1': case '2': case '3': case '4':
16176             case '5': case '6': case '7':
16177                 {
16178                     /* Take 1-3 octal digits */
16179                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16180                     numlen = (strict) ? 4 : 3;
16181                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16182                     RExC_parse += numlen;
16183                     if (numlen != 3) {
16184                         if (strict) {
16185                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16186                             vFAIL("Need exactly 3 octal digits");
16187                         }
16188                         else if (! SIZE_ONLY /* like \08, \178 */
16189                                  && numlen < 3
16190                                  && RExC_parse < RExC_end
16191                                  && isDIGIT(*RExC_parse)
16192                                  && ckWARN(WARN_REGEXP))
16193                         {
16194                             SAVEFREESV(RExC_rx_sv);
16195                             reg_warn_non_literal_string(
16196                                  RExC_parse + 1,
16197                                  form_short_octal_warning(RExC_parse, numlen));
16198                             (void)ReREFCNT_inc(RExC_rx_sv);
16199                         }
16200                     }
16201                     non_portable_endpoint++;
16202                     if (IN_ENCODING && value < 0x100)
16203                         goto recode_encoding;
16204                     break;
16205                 }
16206               recode_encoding:
16207                 if (! RExC_override_recoding) {
16208                     SV* enc = _get_encoding();
16209                     value = reg_recode((U8)value, &enc);
16210                     if (!enc) {
16211                         if (strict) {
16212                             vFAIL("Invalid escape in the specified encoding");
16213                         }
16214                         else if (PASS2) {
16215                             ckWARNreg(RExC_parse,
16216                                   "Invalid escape in the specified encoding");
16217                         }
16218                     }
16219                     break;
16220                 }
16221             default:
16222                 /* Allow \_ to not give an error */
16223                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16224                     if (strict) {
16225                         vFAIL2("Unrecognized escape \\%c in character class",
16226                                (int)value);
16227                     }
16228                     else {
16229                         SAVEFREESV(RExC_rx_sv);
16230                         ckWARN2reg(RExC_parse,
16231                             "Unrecognized escape \\%c in character class passed through",
16232                             (int)value);
16233                         (void)ReREFCNT_inc(RExC_rx_sv);
16234                     }
16235                 }
16236                 break;
16237             }   /* End of switch on char following backslash */
16238         } /* end of handling backslash escape sequences */
16239
16240         /* Here, we have the current token in 'value' */
16241
16242         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
16243             U8 classnum;
16244
16245             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
16246              * literal, as is the character that began the false range, i.e.
16247              * the 'a' in the examples */
16248             if (range) {
16249                 if (!SIZE_ONLY) {
16250                     const int w = (RExC_parse >= rangebegin)
16251                                   ? RExC_parse - rangebegin
16252                                   : 0;
16253                     if (strict) {
16254                         vFAIL2utf8f(
16255                             "False [] range \"%"UTF8f"\"",
16256                             UTF8fARG(UTF, w, rangebegin));
16257                     }
16258                     else {
16259                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
16260                         ckWARN2reg(RExC_parse,
16261                             "False [] range \"%"UTF8f"\"",
16262                             UTF8fARG(UTF, w, rangebegin));
16263                         (void)ReREFCNT_inc(RExC_rx_sv);
16264                         cp_list = add_cp_to_invlist(cp_list, '-');
16265                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
16266                                                              prevvalue);
16267                     }
16268                 }
16269
16270                 range = 0; /* this was not a true range */
16271                 element_count += 2; /* So counts for three values */
16272             }
16273
16274             classnum = namedclass_to_classnum(namedclass);
16275
16276             if (LOC && namedclass < ANYOF_POSIXL_MAX
16277 #ifndef HAS_ISASCII
16278                 && classnum != _CC_ASCII
16279 #endif
16280             ) {
16281                 /* What the Posix classes (like \w, [:space:]) match in locale
16282                  * isn't knowable under locale until actual match time.  Room
16283                  * must be reserved (one time per outer bracketed class) to
16284                  * store such classes.  The space will contain a bit for each
16285                  * named class that is to be matched against.  This isn't
16286                  * needed for \p{} and pseudo-classes, as they are not affected
16287                  * by locale, and hence are dealt with separately */
16288                 if (! need_class) {
16289                     need_class = 1;
16290                     if (SIZE_ONLY) {
16291                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16292                     }
16293                     else {
16294                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16295                     }
16296                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
16297                     ANYOF_POSIXL_ZERO(ret);
16298
16299                     /* We can't change this into some other type of node
16300                      * (unless this is the only element, in which case there
16301                      * are nodes that mean exactly this) as has runtime
16302                      * dependencies */
16303                     optimizable = FALSE;
16304                 }
16305
16306                 /* Coverity thinks it is possible for this to be negative; both
16307                  * jhi and khw think it's not, but be safer */
16308                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16309                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
16310
16311                 /* See if it already matches the complement of this POSIX
16312                  * class */
16313                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16314                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
16315                                                             ? -1
16316                                                             : 1)))
16317                 {
16318                     posixl_matches_all = TRUE;
16319                     break;  /* No need to continue.  Since it matches both
16320                                e.g., \w and \W, it matches everything, and the
16321                                bracketed class can be optimized into qr/./s */
16322                 }
16323
16324                 /* Add this class to those that should be checked at runtime */
16325                 ANYOF_POSIXL_SET(ret, namedclass);
16326
16327                 /* The above-Latin1 characters are not subject to locale rules.
16328                  * Just add them, in the second pass, to the
16329                  * unconditionally-matched list */
16330                 if (! SIZE_ONLY) {
16331                     SV* scratch_list = NULL;
16332
16333                     /* Get the list of the above-Latin1 code points this
16334                      * matches */
16335                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
16336                                           PL_XPosix_ptrs[classnum],
16337
16338                                           /* Odd numbers are complements, like
16339                                            * NDIGIT, NASCII, ... */
16340                                           namedclass % 2 != 0,
16341                                           &scratch_list);
16342                     /* Checking if 'cp_list' is NULL first saves an extra
16343                      * clone.  Its reference count will be decremented at the
16344                      * next union, etc, or if this is the only instance, at the
16345                      * end of the routine */
16346                     if (! cp_list) {
16347                         cp_list = scratch_list;
16348                     }
16349                     else {
16350                         _invlist_union(cp_list, scratch_list, &cp_list);
16351                         SvREFCNT_dec_NN(scratch_list);
16352                     }
16353                     continue;   /* Go get next character */
16354                 }
16355             }
16356             else if (! SIZE_ONLY) {
16357
16358                 /* Here, not in pass1 (in that pass we skip calculating the
16359                  * contents of this class), and is /l, or is a POSIX class for
16360                  * which /l doesn't matter (or is a Unicode property, which is
16361                  * skipped here). */
16362                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
16363                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
16364
16365                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
16366                          * nor /l make a difference in what these match,
16367                          * therefore we just add what they match to cp_list. */
16368                         if (classnum != _CC_VERTSPACE) {
16369                             assert(   namedclass == ANYOF_HORIZWS
16370                                    || namedclass == ANYOF_NHORIZWS);
16371
16372                             /* It turns out that \h is just a synonym for
16373                              * XPosixBlank */
16374                             classnum = _CC_BLANK;
16375                         }
16376
16377                         _invlist_union_maybe_complement_2nd(
16378                                 cp_list,
16379                                 PL_XPosix_ptrs[classnum],
16380                                 namedclass % 2 != 0,    /* Complement if odd
16381                                                           (NHORIZWS, NVERTWS)
16382                                                         */
16383                                 &cp_list);
16384                     }
16385                 }
16386                 else if (UNI_SEMANTICS
16387                         || classnum == _CC_ASCII
16388                         || (DEPENDS_SEMANTICS && (classnum == _CC_DIGIT
16389                                                   || classnum == _CC_XDIGIT)))
16390                 {
16391                     /* We usually have to worry about /d and /a affecting what
16392                      * POSIX classes match, with special code needed for /d
16393                      * because we won't know until runtime what all matches.
16394                      * But there is no extra work needed under /u, and
16395                      * [:ascii:] is unaffected by /a and /d; and :digit: and
16396                      * :xdigit: don't have runtime differences under /d.  So we
16397                      * can special case these, and avoid some extra work below,
16398                      * and at runtime. */
16399                     _invlist_union_maybe_complement_2nd(
16400                                                      simple_posixes,
16401                                                      PL_XPosix_ptrs[classnum],
16402                                                      namedclass % 2 != 0,
16403                                                      &simple_posixes);
16404                 }
16405                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
16406                            complement and use nposixes */
16407                     SV** posixes_ptr = namedclass % 2 == 0
16408                                        ? &posixes
16409                                        : &nposixes;
16410                     _invlist_union_maybe_complement_2nd(
16411                                                      *posixes_ptr,
16412                                                      PL_XPosix_ptrs[classnum],
16413                                                      namedclass % 2 != 0,
16414                                                      posixes_ptr);
16415                 }
16416             }
16417         } /* end of namedclass \blah */
16418
16419         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16420
16421         /* If 'range' is set, 'value' is the ending of a range--check its
16422          * validity.  (If value isn't a single code point in the case of a
16423          * range, we should have figured that out above in the code that
16424          * catches false ranges).  Later, we will handle each individual code
16425          * point in the range.  If 'range' isn't set, this could be the
16426          * beginning of a range, so check for that by looking ahead to see if
16427          * the next real character to be processed is the range indicator--the
16428          * minus sign */
16429
16430         if (range) {
16431 #ifdef EBCDIC
16432             /* For unicode ranges, we have to test that the Unicode as opposed
16433              * to the native values are not decreasing.  (Above 255, there is
16434              * no difference between native and Unicode) */
16435             if (unicode_range && prevvalue < 255 && value < 255) {
16436                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
16437                     goto backwards_range;
16438                 }
16439             }
16440             else
16441 #endif
16442             if (prevvalue > value) /* b-a */ {
16443                 int w;
16444 #ifdef EBCDIC
16445               backwards_range:
16446 #endif
16447                 w = RExC_parse - rangebegin;
16448                 vFAIL2utf8f(
16449                     "Invalid [] range \"%"UTF8f"\"",
16450                     UTF8fARG(UTF, w, rangebegin));
16451                 NOT_REACHED; /* NOTREACHED */
16452             }
16453         }
16454         else {
16455             prevvalue = value; /* save the beginning of the potential range */
16456             if (! stop_at_1     /* Can't be a range if parsing just one thing */
16457                 && *RExC_parse == '-')
16458             {
16459                 char* next_char_ptr = RExC_parse + 1;
16460
16461                 /* Get the next real char after the '-' */
16462                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
16463
16464                 /* If the '-' is at the end of the class (just before the ']',
16465                  * it is a literal minus; otherwise it is a range */
16466                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
16467                     RExC_parse = next_char_ptr;
16468
16469                     /* a bad range like \w-, [:word:]- ? */
16470                     if (namedclass > OOB_NAMEDCLASS) {
16471                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
16472                             const int w = RExC_parse >= rangebegin
16473                                           ?  RExC_parse - rangebegin
16474                                           : 0;
16475                             if (strict) {
16476                                 vFAIL4("False [] range \"%*.*s\"",
16477                                     w, w, rangebegin);
16478                             }
16479                             else if (PASS2) {
16480                                 vWARN4(RExC_parse,
16481                                     "False [] range \"%*.*s\"",
16482                                     w, w, rangebegin);
16483                             }
16484                         }
16485                         if (!SIZE_ONLY) {
16486                             cp_list = add_cp_to_invlist(cp_list, '-');
16487                         }
16488                         element_count++;
16489                     } else
16490                         range = 1;      /* yeah, it's a range! */
16491                     continue;   /* but do it the next time */
16492                 }
16493             }
16494         }
16495
16496         if (namedclass > OOB_NAMEDCLASS) {
16497             continue;
16498         }
16499
16500         /* Here, we have a single value this time through the loop, and
16501          * <prevvalue> is the beginning of the range, if any; or <value> if
16502          * not. */
16503
16504         /* non-Latin1 code point implies unicode semantics.  Must be set in
16505          * pass1 so is there for the whole of pass 2 */
16506         if (value > 255) {
16507             REQUIRE_UNI_RULES(flagp, NULL);
16508         }
16509
16510         /* Ready to process either the single value, or the completed range.
16511          * For single-valued non-inverted ranges, we consider the possibility
16512          * of multi-char folds.  (We made a conscious decision to not do this
16513          * for the other cases because it can often lead to non-intuitive
16514          * results.  For example, you have the peculiar case that:
16515          *  "s s" =~ /^[^\xDF]+$/i => Y
16516          *  "ss"  =~ /^[^\xDF]+$/i => N
16517          *
16518          * See [perl #89750] */
16519         if (FOLD && allow_multi_folds && value == prevvalue) {
16520             if (value == LATIN_SMALL_LETTER_SHARP_S
16521                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
16522                                                         value)))
16523             {
16524                 /* Here <value> is indeed a multi-char fold.  Get what it is */
16525
16526                 U8 foldbuf[UTF8_MAXBYTES_CASE];
16527                 STRLEN foldlen;
16528
16529                 UV folded = _to_uni_fold_flags(
16530                                 value,
16531                                 foldbuf,
16532                                 &foldlen,
16533                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
16534                                                    ? FOLD_FLAGS_NOMIX_ASCII
16535                                                    : 0)
16536                                 );
16537
16538                 /* Here, <folded> should be the first character of the
16539                  * multi-char fold of <value>, with <foldbuf> containing the
16540                  * whole thing.  But, if this fold is not allowed (because of
16541                  * the flags), <fold> will be the same as <value>, and should
16542                  * be processed like any other character, so skip the special
16543                  * handling */
16544                 if (folded != value) {
16545
16546                     /* Skip if we are recursed, currently parsing the class
16547                      * again.  Otherwise add this character to the list of
16548                      * multi-char folds. */
16549                     if (! RExC_in_multi_char_class) {
16550                         STRLEN cp_count = utf8_length(foldbuf,
16551                                                       foldbuf + foldlen);
16552                         SV* multi_fold = sv_2mortal(newSVpvs(""));
16553
16554                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
16555
16556                         multi_char_matches
16557                                         = add_multi_match(multi_char_matches,
16558                                                           multi_fold,
16559                                                           cp_count);
16560
16561                     }
16562
16563                     /* This element should not be processed further in this
16564                      * class */
16565                     element_count--;
16566                     value = save_value;
16567                     prevvalue = save_prevvalue;
16568                     continue;
16569                 }
16570             }
16571         }
16572
16573         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
16574             if (range) {
16575
16576                 /* If the range starts above 255, everything is portable and
16577                  * likely to be so for any forseeable character set, so don't
16578                  * warn. */
16579                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
16580                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
16581                 }
16582                 else if (prevvalue != value) {
16583
16584                     /* Under strict, ranges that stop and/or end in an ASCII
16585                      * printable should have each end point be a portable value
16586                      * for it (preferably like 'A', but we don't warn if it is
16587                      * a (portable) Unicode name or code point), and the range
16588                      * must be be all digits or all letters of the same case.
16589                      * Otherwise, the range is non-portable and unclear as to
16590                      * what it contains */
16591                     if ((isPRINT_A(prevvalue) || isPRINT_A(value))
16592                         && (non_portable_endpoint
16593                             || ! ((isDIGIT_A(prevvalue) && isDIGIT_A(value))
16594                                    || (isLOWER_A(prevvalue) && isLOWER_A(value))
16595                                    || (isUPPER_A(prevvalue) && isUPPER_A(value)))))
16596                     {
16597                         vWARN(RExC_parse, "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\"");
16598                     }
16599                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
16600
16601                         /* But the nature of Unicode and languages mean we
16602                          * can't do the same checks for above-ASCII ranges,
16603                          * except in the case of digit ones.  These should
16604                          * contain only digits from the same group of 10.  The
16605                          * ASCII case is handled just above.  0x660 is the
16606                          * first digit character beyond ASCII.  Hence here, the
16607                          * range could be a range of digits.  Find out.  */
16608                         IV index_start = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16609                                                          prevvalue);
16610                         IV index_final = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16611                                                          value);
16612
16613                         /* If the range start and final points are in the same
16614                          * inversion list element, it means that either both
16615                          * are not digits, or both are digits in a consecutive
16616                          * sequence of digits.  (So far, Unicode has kept all
16617                          * such sequences as distinct groups of 10, but assert
16618                          * to make sure).  If the end points are not in the
16619                          * same element, neither should be a digit. */
16620                         if (index_start == index_final) {
16621                             assert(! ELEMENT_RANGE_MATCHES_INVLIST(index_start)
16622                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16623                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16624                                == 10)
16625                                /* But actually Unicode did have one group of 11
16626                                 * 'digits' in 5.2, so in case we are operating
16627                                 * on that version, let that pass */
16628                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16629                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16630                                 == 11
16631                                && invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16632                                 == 0x19D0)
16633                             );
16634                         }
16635                         else if ((index_start >= 0
16636                                   && ELEMENT_RANGE_MATCHES_INVLIST(index_start))
16637                                  || (index_final >= 0
16638                                      && ELEMENT_RANGE_MATCHES_INVLIST(index_final)))
16639                         {
16640                             vWARN(RExC_parse, "Ranges of digits should be from the same group of 10");
16641                         }
16642                     }
16643                 }
16644             }
16645             if ((! range || prevvalue == value) && non_portable_endpoint) {
16646                 if (isPRINT_A(value)) {
16647                     char literal[3];
16648                     unsigned d = 0;
16649                     if (isBACKSLASHED_PUNCT(value)) {
16650                         literal[d++] = '\\';
16651                     }
16652                     literal[d++] = (char) value;
16653                     literal[d++] = '\0';
16654
16655                     vWARN4(RExC_parse,
16656                            "\"%.*s\" is more clearly written simply as \"%s\"",
16657                            (int) (RExC_parse - rangebegin),
16658                            rangebegin,
16659                            literal
16660                         );
16661                 }
16662                 else if isMNEMONIC_CNTRL(value) {
16663                     vWARN4(RExC_parse,
16664                            "\"%.*s\" is more clearly written simply as \"%s\"",
16665                            (int) (RExC_parse - rangebegin),
16666                            rangebegin,
16667                            cntrl_to_mnemonic((U8) value)
16668                         );
16669                 }
16670             }
16671         }
16672
16673         /* Deal with this element of the class */
16674         if (! SIZE_ONLY) {
16675
16676 #ifndef EBCDIC
16677             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16678                                                      prevvalue, value);
16679 #else
16680             /* On non-ASCII platforms, for ranges that span all of 0..255, and
16681              * ones that don't require special handling, we can just add the
16682              * range like we do for ASCII platforms */
16683             if ((UNLIKELY(prevvalue == 0) && value >= 255)
16684                 || ! (prevvalue < 256
16685                       && (unicode_range
16686                           || (! non_portable_endpoint
16687                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
16688                                   || (isUPPER_A(prevvalue)
16689                                       && isUPPER_A(value)))))))
16690             {
16691                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16692                                                          prevvalue, value);
16693             }
16694             else {
16695                 /* Here, requires special handling.  This can be because it is
16696                  * a range whose code points are considered to be Unicode, and
16697                  * so must be individually translated into native, or because
16698                  * its a subrange of 'A-Z' or 'a-z' which each aren't
16699                  * contiguous in EBCDIC, but we have defined them to include
16700                  * only the "expected" upper or lower case ASCII alphabetics.
16701                  * Subranges above 255 are the same in native and Unicode, so
16702                  * can be added as a range */
16703                 U8 start = NATIVE_TO_LATIN1(prevvalue);
16704                 unsigned j;
16705                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
16706                 for (j = start; j <= end; j++) {
16707                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
16708                 }
16709                 if (value > 255) {
16710                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16711                                                              256, value);
16712                 }
16713             }
16714 #endif
16715         }
16716
16717         range = 0; /* this range (if it was one) is done now */
16718     } /* End of loop through all the text within the brackets */
16719
16720
16721     if (   posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
16722         output_or_return_posix_warnings(pRExC_state, posix_warnings,
16723                                         return_posix_warnings);
16724     }
16725
16726     /* If anything in the class expands to more than one character, we have to
16727      * deal with them by building up a substitute parse string, and recursively
16728      * calling reg() on it, instead of proceeding */
16729     if (multi_char_matches) {
16730         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
16731         I32 cp_count;
16732         STRLEN len;
16733         char *save_end = RExC_end;
16734         char *save_parse = RExC_parse;
16735         char *save_start = RExC_start;
16736         STRLEN prefix_end = 0;      /* We copy the character class after a
16737                                        prefix supplied here.  This is the size
16738                                        + 1 of that prefix */
16739         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
16740                                        a "|" */
16741         I32 reg_flags;
16742
16743         assert(! invert);
16744         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
16745
16746 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
16747            because too confusing */
16748         if (invert) {
16749             sv_catpv(substitute_parse, "(?:");
16750         }
16751 #endif
16752
16753         /* Look at the longest folds first */
16754         for (cp_count = av_tindex_nomg(multi_char_matches);
16755                         cp_count > 0;
16756                         cp_count--)
16757         {
16758
16759             if (av_exists(multi_char_matches, cp_count)) {
16760                 AV** this_array_ptr;
16761                 SV* this_sequence;
16762
16763                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
16764                                                  cp_count, FALSE);
16765                 while ((this_sequence = av_pop(*this_array_ptr)) !=
16766                                                                 &PL_sv_undef)
16767                 {
16768                     if (! first_time) {
16769                         sv_catpv(substitute_parse, "|");
16770                     }
16771                     first_time = FALSE;
16772
16773                     sv_catpv(substitute_parse, SvPVX(this_sequence));
16774                 }
16775             }
16776         }
16777
16778         /* If the character class contains anything else besides these
16779          * multi-character folds, have to include it in recursive parsing */
16780         if (element_count) {
16781             sv_catpv(substitute_parse, "|[");
16782             prefix_end = SvCUR(substitute_parse);
16783             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
16784
16785             /* Put in a closing ']' only if not going off the end, as otherwise
16786              * we are adding something that really isn't there */
16787             if (RExC_parse < RExC_end) {
16788                 sv_catpv(substitute_parse, "]");
16789             }
16790         }
16791
16792         sv_catpv(substitute_parse, ")");
16793 #if 0
16794         if (invert) {
16795             /* This is a way to get the parse to skip forward a whole named
16796              * sequence instead of matching the 2nd character when it fails the
16797              * first */
16798             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
16799         }
16800 #endif
16801
16802         /* Set up the data structure so that any errors will be properly
16803          * reported.  See the comments at the definition of
16804          * REPORT_LOCATION_ARGS for details */
16805         RExC_precomp_adj = orig_parse - RExC_precomp;
16806         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
16807         RExC_adjusted_start = RExC_start + prefix_end;
16808         RExC_end = RExC_parse + len;
16809         RExC_in_multi_char_class = 1;
16810         RExC_override_recoding = 1;
16811         RExC_emit = (regnode *)orig_emit;
16812
16813         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
16814
16815         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
16816
16817         /* And restore so can parse the rest of the pattern */
16818         RExC_parse = save_parse;
16819         RExC_start = RExC_adjusted_start = save_start;
16820         RExC_precomp_adj = 0;
16821         RExC_end = save_end;
16822         RExC_in_multi_char_class = 0;
16823         RExC_override_recoding = 0;
16824         SvREFCNT_dec_NN(multi_char_matches);
16825         return ret;
16826     }
16827
16828     /* Here, we've gone through the entire class and dealt with multi-char
16829      * folds.  We are now in a position that we can do some checks to see if we
16830      * can optimize this ANYOF node into a simpler one, even in Pass 1.
16831      * Currently we only do two checks:
16832      * 1) is in the unlikely event that the user has specified both, eg. \w and
16833      *    \W under /l, then the class matches everything.  (This optimization
16834      *    is done only to make the optimizer code run later work.)
16835      * 2) if the character class contains only a single element (including a
16836      *    single range), we see if there is an equivalent node for it.
16837      * Other checks are possible */
16838     if (   optimizable
16839         && ! ret_invlist   /* Can't optimize if returning the constructed
16840                               inversion list */
16841         && (UNLIKELY(posixl_matches_all) || element_count == 1))
16842     {
16843         U8 op = END;
16844         U8 arg = 0;
16845
16846         if (UNLIKELY(posixl_matches_all)) {
16847             op = SANY;
16848         }
16849         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
16850                                                    class, like \w or [:digit:]
16851                                                    or \p{foo} */
16852
16853             /* All named classes are mapped into POSIXish nodes, with its FLAG
16854              * argument giving which class it is */
16855             switch ((I32)namedclass) {
16856                 case ANYOF_UNIPROP:
16857                     break;
16858
16859                 /* These don't depend on the charset modifiers.  They always
16860                  * match under /u rules */
16861                 case ANYOF_NHORIZWS:
16862                 case ANYOF_HORIZWS:
16863                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
16864                     /* FALLTHROUGH */
16865
16866                 case ANYOF_NVERTWS:
16867                 case ANYOF_VERTWS:
16868                     op = POSIXU;
16869                     goto join_posix;
16870
16871                 /* The actual POSIXish node for all the rest depends on the
16872                  * charset modifier.  The ones in the first set depend only on
16873                  * ASCII or, if available on this platform, also locale */
16874                 case ANYOF_ASCII:
16875                 case ANYOF_NASCII:
16876 #ifdef HAS_ISASCII
16877                     op = (LOC) ? POSIXL : POSIXA;
16878 #else
16879                     op = POSIXA;
16880 #endif
16881                     goto join_posix;
16882
16883                 /* The following don't have any matches in the upper Latin1
16884                  * range, hence /d is equivalent to /u for them.  Making it /u
16885                  * saves some branches at runtime */
16886                 case ANYOF_DIGIT:
16887                 case ANYOF_NDIGIT:
16888                 case ANYOF_XDIGIT:
16889                 case ANYOF_NXDIGIT:
16890                     if (! DEPENDS_SEMANTICS) {
16891                         goto treat_as_default;
16892                     }
16893
16894                     op = POSIXU;
16895                     goto join_posix;
16896
16897                 /* The following change to CASED under /i */
16898                 case ANYOF_LOWER:
16899                 case ANYOF_NLOWER:
16900                 case ANYOF_UPPER:
16901                 case ANYOF_NUPPER:
16902                     if (FOLD) {
16903                         namedclass = ANYOF_CASED + (namedclass % 2);
16904                     }
16905                     /* FALLTHROUGH */
16906
16907                 /* The rest have more possibilities depending on the charset.
16908                  * We take advantage of the enum ordering of the charset
16909                  * modifiers to get the exact node type, */
16910                 default:
16911                   treat_as_default:
16912                     op = POSIXD + get_regex_charset(RExC_flags);
16913                     if (op > POSIXA) { /* /aa is same as /a */
16914                         op = POSIXA;
16915                     }
16916
16917                   join_posix:
16918                     /* The odd numbered ones are the complements of the
16919                      * next-lower even number one */
16920                     if (namedclass % 2 == 1) {
16921                         invert = ! invert;
16922                         namedclass--;
16923                     }
16924                     arg = namedclass_to_classnum(namedclass);
16925                     break;
16926             }
16927         }
16928         else if (value == prevvalue) {
16929
16930             /* Here, the class consists of just a single code point */
16931
16932             if (invert) {
16933                 if (! LOC && value == '\n') {
16934                     op = REG_ANY; /* Optimize [^\n] */
16935                     *flagp |= HASWIDTH|SIMPLE;
16936                     MARK_NAUGHTY(1);
16937                 }
16938             }
16939             else if (value < 256 || UTF) {
16940
16941                 /* Optimize a single value into an EXACTish node, but not if it
16942                  * would require converting the pattern to UTF-8. */
16943                 op = compute_EXACTish(pRExC_state);
16944             }
16945         } /* Otherwise is a range */
16946         else if (! LOC) {   /* locale could vary these */
16947             if (prevvalue == '0') {
16948                 if (value == '9') {
16949                     arg = _CC_DIGIT;
16950                     op = POSIXA;
16951                 }
16952             }
16953             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
16954                 /* We can optimize A-Z or a-z, but not if they could match
16955                  * something like the KELVIN SIGN under /i. */
16956                 if (prevvalue == 'A') {
16957                     if (value == 'Z'
16958 #ifdef EBCDIC
16959                         && ! non_portable_endpoint
16960 #endif
16961                     ) {
16962                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
16963                         op = POSIXA;
16964                     }
16965                 }
16966                 else if (prevvalue == 'a') {
16967                     if (value == 'z'
16968 #ifdef EBCDIC
16969                         && ! non_portable_endpoint
16970 #endif
16971                     ) {
16972                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
16973                         op = POSIXA;
16974                     }
16975                 }
16976             }
16977         }
16978
16979         /* Here, we have changed <op> away from its initial value iff we found
16980          * an optimization */
16981         if (op != END) {
16982
16983             /* Throw away this ANYOF regnode, and emit the calculated one,
16984              * which should correspond to the beginning, not current, state of
16985              * the parse */
16986             const char * cur_parse = RExC_parse;
16987             RExC_parse = (char *)orig_parse;
16988             if ( SIZE_ONLY) {
16989                 if (! LOC) {
16990
16991                     /* To get locale nodes to not use the full ANYOF size would
16992                      * require moving the code above that writes the portions
16993                      * of it that aren't in other nodes to after this point.
16994                      * e.g.  ANYOF_POSIXL_SET */
16995                     RExC_size = orig_size;
16996                 }
16997             }
16998             else {
16999                 RExC_emit = (regnode *)orig_emit;
17000                 if (PL_regkind[op] == POSIXD) {
17001                     if (op == POSIXL) {
17002                         RExC_contains_locale = 1;
17003                     }
17004                     if (invert) {
17005                         op += NPOSIXD - POSIXD;
17006                     }
17007                 }
17008             }
17009
17010             ret = reg_node(pRExC_state, op);
17011
17012             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17013                 if (! SIZE_ONLY) {
17014                     FLAGS(ret) = arg;
17015                 }
17016                 *flagp |= HASWIDTH|SIMPLE;
17017             }
17018             else if (PL_regkind[op] == EXACT) {
17019                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17020                                            TRUE /* downgradable to EXACT */
17021                                            );
17022             }
17023
17024             RExC_parse = (char *) cur_parse;
17025
17026             SvREFCNT_dec(posixes);
17027             SvREFCNT_dec(nposixes);
17028             SvREFCNT_dec(simple_posixes);
17029             SvREFCNT_dec(cp_list);
17030             SvREFCNT_dec(cp_foldable_list);
17031             return ret;
17032         }
17033     }
17034
17035     if (SIZE_ONLY)
17036         return ret;
17037     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17038
17039     /* If folding, we calculate all characters that could fold to or from the
17040      * ones already on the list */
17041     if (cp_foldable_list) {
17042         if (FOLD) {
17043             UV start, end;      /* End points of code point ranges */
17044
17045             SV* fold_intersection = NULL;
17046             SV** use_list;
17047
17048             /* Our calculated list will be for Unicode rules.  For locale
17049              * matching, we have to keep a separate list that is consulted at
17050              * runtime only when the locale indicates Unicode rules.  For
17051              * non-locale, we just use the general list */
17052             if (LOC) {
17053                 use_list = &only_utf8_locale_list;
17054             }
17055             else {
17056                 use_list = &cp_list;
17057             }
17058
17059             /* Only the characters in this class that participate in folds need
17060              * be checked.  Get the intersection of this class and all the
17061              * possible characters that are foldable.  This can quickly narrow
17062              * down a large class */
17063             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17064                                   &fold_intersection);
17065
17066             /* The folds for all the Latin1 characters are hard-coded into this
17067              * program, but we have to go out to disk to get the others. */
17068             if (invlist_highest(cp_foldable_list) >= 256) {
17069
17070                 /* This is a hash that for a particular fold gives all
17071                  * characters that are involved in it */
17072                 if (! PL_utf8_foldclosures) {
17073                     _load_PL_utf8_foldclosures();
17074                 }
17075             }
17076
17077             /* Now look at the foldable characters in this class individually */
17078             invlist_iterinit(fold_intersection);
17079             while (invlist_iternext(fold_intersection, &start, &end)) {
17080                 UV j;
17081
17082                 /* Look at every character in the range */
17083                 for (j = start; j <= end; j++) {
17084                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17085                     STRLEN foldlen;
17086                     SV** listp;
17087
17088                     if (j < 256) {
17089
17090                         if (IS_IN_SOME_FOLD_L1(j)) {
17091
17092                             /* ASCII is always matched; non-ASCII is matched
17093                              * only under Unicode rules (which could happen
17094                              * under /l if the locale is a UTF-8 one */
17095                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17096                                 *use_list = add_cp_to_invlist(*use_list,
17097                                                             PL_fold_latin1[j]);
17098                             }
17099                             else {
17100                                 has_upper_latin1_only_utf8_matches
17101                                     = add_cp_to_invlist(
17102                                             has_upper_latin1_only_utf8_matches,
17103                                             PL_fold_latin1[j]);
17104                             }
17105                         }
17106
17107                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17108                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17109                         {
17110                             add_above_Latin1_folds(pRExC_state,
17111                                                    (U8) j,
17112                                                    use_list);
17113                         }
17114                         continue;
17115                     }
17116
17117                     /* Here is an above Latin1 character.  We don't have the
17118                      * rules hard-coded for it.  First, get its fold.  This is
17119                      * the simple fold, as the multi-character folds have been
17120                      * handled earlier and separated out */
17121                     _to_uni_fold_flags(j, foldbuf, &foldlen,
17122                                                         (ASCII_FOLD_RESTRICTED)
17123                                                         ? FOLD_FLAGS_NOMIX_ASCII
17124                                                         : 0);
17125
17126                     /* Single character fold of above Latin1.  Add everything in
17127                     * its fold closure to the list that this node should match.
17128                     * The fold closures data structure is a hash with the keys
17129                     * being the UTF-8 of every character that is folded to, like
17130                     * 'k', and the values each an array of all code points that
17131                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
17132                     * Multi-character folds are not included */
17133                     if ((listp = hv_fetch(PL_utf8_foldclosures,
17134                                         (char *) foldbuf, foldlen, FALSE)))
17135                     {
17136                         AV* list = (AV*) *listp;
17137                         IV k;
17138                         for (k = 0; k <= av_tindex_nomg(list); k++) {
17139                             SV** c_p = av_fetch(list, k, FALSE);
17140                             UV c;
17141                             assert(c_p);
17142
17143                             c = SvUV(*c_p);
17144
17145                             /* /aa doesn't allow folds between ASCII and non- */
17146                             if ((ASCII_FOLD_RESTRICTED
17147                                 && (isASCII(c) != isASCII(j))))
17148                             {
17149                                 continue;
17150                             }
17151
17152                             /* Folds under /l which cross the 255/256 boundary
17153                              * are added to a separate list.  (These are valid
17154                              * only when the locale is UTF-8.) */
17155                             if (c < 256 && LOC) {
17156                                 *use_list = add_cp_to_invlist(*use_list, c);
17157                                 continue;
17158                             }
17159
17160                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17161                             {
17162                                 cp_list = add_cp_to_invlist(cp_list, c);
17163                             }
17164                             else {
17165                                 /* Similarly folds involving non-ascii Latin1
17166                                 * characters under /d are added to their list */
17167                                 has_upper_latin1_only_utf8_matches
17168                                         = add_cp_to_invlist(
17169                                            has_upper_latin1_only_utf8_matches,
17170                                            c);
17171                             }
17172                         }
17173                     }
17174                 }
17175             }
17176             SvREFCNT_dec_NN(fold_intersection);
17177         }
17178
17179         /* Now that we have finished adding all the folds, there is no reason
17180          * to keep the foldable list separate */
17181         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17182         SvREFCNT_dec_NN(cp_foldable_list);
17183     }
17184
17185     /* And combine the result (if any) with any inversion list from posix
17186      * classes.  The lists are kept separate up to now because we don't want to
17187      * fold the classes (folding of those is automatically handled by the swash
17188      * fetching code) */
17189     if (simple_posixes) {
17190         _invlist_union(cp_list, simple_posixes, &cp_list);
17191         SvREFCNT_dec_NN(simple_posixes);
17192     }
17193     if (posixes || nposixes) {
17194         if (posixes && AT_LEAST_ASCII_RESTRICTED) {
17195             /* Under /a and /aa, nothing above ASCII matches these */
17196             _invlist_intersection(posixes,
17197                                   PL_XPosix_ptrs[_CC_ASCII],
17198                                   &posixes);
17199         }
17200         if (nposixes) {
17201             if (DEPENDS_SEMANTICS) {
17202                 /* Under /d, everything in the upper half of the Latin1 range
17203                  * matches these complements */
17204                 ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17205             }
17206             else if (AT_LEAST_ASCII_RESTRICTED) {
17207                 /* Under /a and /aa, everything above ASCII matches these
17208                  * complements */
17209                 _invlist_union_complement_2nd(nposixes,
17210                                               PL_XPosix_ptrs[_CC_ASCII],
17211                                               &nposixes);
17212             }
17213             if (posixes) {
17214                 _invlist_union(posixes, nposixes, &posixes);
17215                 SvREFCNT_dec_NN(nposixes);
17216             }
17217             else {
17218                 posixes = nposixes;
17219             }
17220         }
17221         if (! DEPENDS_SEMANTICS) {
17222             if (cp_list) {
17223                 _invlist_union(cp_list, posixes, &cp_list);
17224                 SvREFCNT_dec_NN(posixes);
17225             }
17226             else {
17227                 cp_list = posixes;
17228             }
17229         }
17230         else {
17231             /* Under /d, we put into a separate list the Latin1 things that
17232              * match only when the target string is utf8 */
17233             SV* nonascii_but_latin1_properties = NULL;
17234             _invlist_intersection(posixes, PL_UpperLatin1,
17235                                   &nonascii_but_latin1_properties);
17236             _invlist_subtract(posixes, nonascii_but_latin1_properties,
17237                               &posixes);
17238             if (cp_list) {
17239                 _invlist_union(cp_list, posixes, &cp_list);
17240                 SvREFCNT_dec_NN(posixes);
17241             }
17242             else {
17243                 cp_list = posixes;
17244             }
17245
17246             if (has_upper_latin1_only_utf8_matches) {
17247                 _invlist_union(has_upper_latin1_only_utf8_matches,
17248                                nonascii_but_latin1_properties,
17249                                &has_upper_latin1_only_utf8_matches);
17250                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
17251             }
17252             else {
17253                 has_upper_latin1_only_utf8_matches
17254                                             = nonascii_but_latin1_properties;
17255             }
17256         }
17257     }
17258
17259     /* And combine the result (if any) with any inversion list from properties.
17260      * The lists are kept separate up to now so that we can distinguish the two
17261      * in regards to matching above-Unicode.  A run-time warning is generated
17262      * if a Unicode property is matched against a non-Unicode code point. But,
17263      * we allow user-defined properties to match anything, without any warning,
17264      * and we also suppress the warning if there is a portion of the character
17265      * class that isn't a Unicode property, and which matches above Unicode, \W
17266      * or [\x{110000}] for example.
17267      * (Note that in this case, unlike the Posix one above, there is no
17268      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
17269      * forces Unicode semantics */
17270     if (properties) {
17271         if (cp_list) {
17272
17273             /* If it matters to the final outcome, see if a non-property
17274              * component of the class matches above Unicode.  If so, the
17275              * warning gets suppressed.  This is true even if just a single
17276              * such code point is specified, as, though not strictly correct if
17277              * another such code point is matched against, the fact that they
17278              * are using above-Unicode code points indicates they should know
17279              * the issues involved */
17280             if (warn_super) {
17281                 warn_super = ! (invert
17282                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
17283             }
17284
17285             _invlist_union(properties, cp_list, &cp_list);
17286             SvREFCNT_dec_NN(properties);
17287         }
17288         else {
17289             cp_list = properties;
17290         }
17291
17292         if (warn_super) {
17293             ANYOF_FLAGS(ret)
17294              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17295
17296             /* Because an ANYOF node is the only one that warns, this node
17297              * can't be optimized into something else */
17298             optimizable = FALSE;
17299         }
17300     }
17301
17302     /* Here, we have calculated what code points should be in the character
17303      * class.
17304      *
17305      * Now we can see about various optimizations.  Fold calculation (which we
17306      * did above) needs to take place before inversion.  Otherwise /[^k]/i
17307      * would invert to include K, which under /i would match k, which it
17308      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
17309      * folded until runtime */
17310
17311     /* If we didn't do folding, it's because some information isn't available
17312      * until runtime; set the run-time fold flag for these.  (We don't have to
17313      * worry about properties folding, as that is taken care of by the swash
17314      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
17315      * locales, or the class matches at least one 0-255 range code point */
17316     if (LOC && FOLD) {
17317
17318         /* Some things on the list might be unconditionally included because of
17319          * other components.  Remove them, and clean up the list if it goes to
17320          * 0 elements */
17321         if (only_utf8_locale_list && cp_list) {
17322             _invlist_subtract(only_utf8_locale_list, cp_list,
17323                               &only_utf8_locale_list);
17324
17325             if (_invlist_len(only_utf8_locale_list) == 0) {
17326                 SvREFCNT_dec_NN(only_utf8_locale_list);
17327                 only_utf8_locale_list = NULL;
17328             }
17329         }
17330         if (only_utf8_locale_list) {
17331             ANYOF_FLAGS(ret)
17332                  |=  ANYOFL_FOLD
17333                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
17334         }
17335         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
17336             UV start, end;
17337             invlist_iterinit(cp_list);
17338             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
17339                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
17340             }
17341             invlist_iterfinish(cp_list);
17342         }
17343     }
17344
17345 #define MATCHES_ALL_NON_UTF8_NON_ASCII(ret)                                 \
17346     (   DEPENDS_SEMANTICS                                                   \
17347      && (ANYOF_FLAGS(ret)                                                   \
17348         & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
17349
17350     /* See if we can simplify things under /d */
17351     if (   has_upper_latin1_only_utf8_matches
17352         || MATCHES_ALL_NON_UTF8_NON_ASCII(ret))
17353     {
17354         /* But not if we are inverting, as that screws it up */
17355         if (! invert) {
17356             if (has_upper_latin1_only_utf8_matches) {
17357                 if (MATCHES_ALL_NON_UTF8_NON_ASCII(ret)) {
17358
17359                     /* Here, we have both the flag and inversion list.  Any
17360                      * character in 'has_upper_latin1_only_utf8_matches'
17361                      * matches when UTF-8 is in effect, but it also matches
17362                      * when UTF-8 is not in effect because of
17363                      * MATCHES_ALL_NON_UTF8_NON_ASCII.  Therefore it matches
17364                      * unconditionally, so can be added to the regular list,
17365                      * and 'has_upper_latin1_only_utf8_matches' cleared */
17366                     _invlist_union(cp_list,
17367                                    has_upper_latin1_only_utf8_matches,
17368                                    &cp_list);
17369                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17370                     has_upper_latin1_only_utf8_matches = NULL;
17371                 }
17372                 else if (cp_list) {
17373
17374                     /* Here, 'cp_list' gives chars that always match, and
17375                      * 'has_upper_latin1_only_utf8_matches' gives chars that
17376                      * were specified to match only if the target string is in
17377                      * UTF-8.  It may be that these overlap, so we can subtract
17378                      * the unconditionally matching from the conditional ones,
17379                      * to make the conditional list as small as possible,
17380                      * perhaps even clearing it, in which case more
17381                      * optimizations are possible later */
17382                     _invlist_subtract(has_upper_latin1_only_utf8_matches,
17383                                       cp_list,
17384                                       &has_upper_latin1_only_utf8_matches);
17385                     if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
17386                         SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17387                         has_upper_latin1_only_utf8_matches = NULL;
17388                     }
17389                 }
17390             }
17391
17392             /* Similarly, if the unconditional matches include every upper
17393              * latin1 character, we can clear that flag to permit later
17394              * optimizations */
17395             if (cp_list && MATCHES_ALL_NON_UTF8_NON_ASCII(ret)) {
17396                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
17397                 _invlist_subtract(only_non_utf8_list, cp_list,
17398                                   &only_non_utf8_list);
17399                 if (_invlist_len(only_non_utf8_list) == 0) {
17400                     ANYOF_FLAGS(ret) &= ~ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17401                 }
17402                 SvREFCNT_dec_NN(only_non_utf8_list);
17403                 only_non_utf8_list = NULL;;
17404             }
17405         }
17406
17407         /* If we haven't gotten rid of all conditional matching, we change the
17408          * regnode type to indicate that */
17409         if (   has_upper_latin1_only_utf8_matches
17410             || MATCHES_ALL_NON_UTF8_NON_ASCII(ret))
17411         {
17412             OP(ret) = ANYOFD;
17413             optimizable = FALSE;
17414         }
17415     }
17416 #undef MATCHES_ALL_NON_UTF8_NON_ASCII
17417
17418     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
17419      * at compile time.  Besides not inverting folded locale now, we can't
17420      * invert if there are things such as \w, which aren't known until runtime
17421      * */
17422     if (cp_list
17423         && invert
17424         && OP(ret) != ANYOFD
17425         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
17426         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17427     {
17428         _invlist_invert(cp_list);
17429
17430         /* Any swash can't be used as-is, because we've inverted things */
17431         if (swash) {
17432             SvREFCNT_dec_NN(swash);
17433             swash = NULL;
17434         }
17435
17436         /* Clear the invert flag since have just done it here */
17437         invert = FALSE;
17438     }
17439
17440     if (ret_invlist) {
17441         assert(cp_list);
17442
17443         *ret_invlist = cp_list;
17444         SvREFCNT_dec(swash);
17445
17446         /* Discard the generated node */
17447         if (SIZE_ONLY) {
17448             RExC_size = orig_size;
17449         }
17450         else {
17451             RExC_emit = orig_emit;
17452         }
17453         return orig_emit;
17454     }
17455
17456     /* Some character classes are equivalent to other nodes.  Such nodes take
17457      * up less room and generally fewer operations to execute than ANYOF nodes.
17458      * Above, we checked for and optimized into some such equivalents for
17459      * certain common classes that are easy to test.  Getting to this point in
17460      * the code means that the class didn't get optimized there.  Since this
17461      * code is only executed in Pass 2, it is too late to save space--it has
17462      * been allocated in Pass 1, and currently isn't given back.  But turning
17463      * things into an EXACTish node can allow the optimizer to join it to any
17464      * adjacent such nodes.  And if the class is equivalent to things like /./,
17465      * expensive run-time swashes can be avoided.  Now that we have more
17466      * complete information, we can find things necessarily missed by the
17467      * earlier code.  Another possible "optimization" that isn't done is that
17468      * something like [Ee] could be changed into an EXACTFU.  khw tried this
17469      * and found that the ANYOF is faster, including for code points not in the
17470      * bitmap.  This still might make sense to do, provided it got joined with
17471      * an adjacent node(s) to create a longer EXACTFU one.  This could be
17472      * accomplished by creating a pseudo ANYOF_EXACTFU node type that the join
17473      * routine would know is joinable.  If that didn't happen, the node type
17474      * could then be made a straight ANYOF */
17475
17476     if (optimizable && cp_list && ! invert) {
17477         UV start, end;
17478         U8 op = END;  /* The optimzation node-type */
17479         int posix_class = -1;   /* Illegal value */
17480         const char * cur_parse= RExC_parse;
17481
17482         invlist_iterinit(cp_list);
17483         if (! invlist_iternext(cp_list, &start, &end)) {
17484
17485             /* Here, the list is empty.  This happens, for example, when a
17486              * Unicode property that doesn't match anything is the only element
17487              * in the character class (perluniprops.pod notes such properties).
17488              * */
17489             op = OPFAIL;
17490             *flagp |= HASWIDTH|SIMPLE;
17491         }
17492         else if (start == end) {    /* The range is a single code point */
17493             if (! invlist_iternext(cp_list, &start, &end)
17494
17495                     /* Don't do this optimization if it would require changing
17496                      * the pattern to UTF-8 */
17497                 && (start < 256 || UTF))
17498             {
17499                 /* Here, the list contains a single code point.  Can optimize
17500                  * into an EXACTish node */
17501
17502                 value = start;
17503
17504                 if (! FOLD) {
17505                     op = (LOC)
17506                          ? EXACTL
17507                          : EXACT;
17508                 }
17509                 else if (LOC) {
17510
17511                     /* A locale node under folding with one code point can be
17512                      * an EXACTFL, as its fold won't be calculated until
17513                      * runtime */
17514                     op = EXACTFL;
17515                 }
17516                 else {
17517
17518                     /* Here, we are generally folding, but there is only one
17519                      * code point to match.  If we have to, we use an EXACT
17520                      * node, but it would be better for joining with adjacent
17521                      * nodes in the optimization pass if we used the same
17522                      * EXACTFish node that any such are likely to be.  We can
17523                      * do this iff the code point doesn't participate in any
17524                      * folds.  For example, an EXACTF of a colon is the same as
17525                      * an EXACT one, since nothing folds to or from a colon. */
17526                     if (value < 256) {
17527                         if (IS_IN_SOME_FOLD_L1(value)) {
17528                             op = EXACT;
17529                         }
17530                     }
17531                     else {
17532                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
17533                             op = EXACT;
17534                         }
17535                     }
17536
17537                     /* If we haven't found the node type, above, it means we
17538                      * can use the prevailing one */
17539                     if (op == END) {
17540                         op = compute_EXACTish(pRExC_state);
17541                     }
17542                 }
17543             }
17544         }   /* End of first range contains just a single code point */
17545         else if (start == 0) {
17546             if (end == UV_MAX) {
17547                 op = SANY;
17548                 *flagp |= HASWIDTH|SIMPLE;
17549                 MARK_NAUGHTY(1);
17550             }
17551             else if (end == '\n' - 1
17552                     && invlist_iternext(cp_list, &start, &end)
17553                     && start == '\n' + 1 && end == UV_MAX)
17554             {
17555                 op = REG_ANY;
17556                 *flagp |= HASWIDTH|SIMPLE;
17557                 MARK_NAUGHTY(1);
17558             }
17559         }
17560         invlist_iterfinish(cp_list);
17561
17562         if (op == END) {
17563             const UV cp_list_len = _invlist_len(cp_list);
17564             const UV* cp_list_array = invlist_array(cp_list);
17565
17566             /* Here, didn't find an optimization.  See if this matches any of
17567              * the POSIX classes.  These run slightly faster for above-Unicode
17568              * code points, so don't bother with POSIXA ones nor the 2 that
17569              * have no above-Unicode matches.  We can avoid these checks unless
17570              * the ANYOF matches at least as high as the lowest POSIX one
17571              * (which was manually found to be \v.  The actual code point may
17572              * increase in later Unicode releases, if a higher code point is
17573              * assigned to be \v, but this code will never break.  It would
17574              * just mean we could execute the checks for posix optimizations
17575              * unnecessarily) */
17576
17577             if (cp_list_array[cp_list_len-1] > 0x2029) {
17578                 for (posix_class = 0;
17579                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
17580                      posix_class++)
17581                 {
17582                     int try_inverted;
17583                     if (posix_class == _CC_ASCII || posix_class == _CC_CNTRL) {
17584                         continue;
17585                     }
17586                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
17587
17588                         /* Check if matches normal or inverted */
17589                         if (_invlistEQ(cp_list,
17590                                        PL_XPosix_ptrs[posix_class],
17591                                        try_inverted))
17592                         {
17593                             op = (try_inverted)
17594                                  ? NPOSIXU
17595                                  : POSIXU;
17596                             *flagp |= HASWIDTH|SIMPLE;
17597                             goto found_posix;
17598                         }
17599                     }
17600                 }
17601               found_posix: ;
17602             }
17603         }
17604
17605         if (op != END) {
17606             RExC_parse = (char *)orig_parse;
17607             RExC_emit = (regnode *)orig_emit;
17608
17609             if (regarglen[op]) {
17610                 ret = reganode(pRExC_state, op, 0);
17611             } else {
17612                 ret = reg_node(pRExC_state, op);
17613             }
17614
17615             RExC_parse = (char *)cur_parse;
17616
17617             if (PL_regkind[op] == EXACT) {
17618                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17619                                            TRUE /* downgradable to EXACT */
17620                                           );
17621             }
17622             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17623                 FLAGS(ret) = posix_class;
17624             }
17625
17626             SvREFCNT_dec_NN(cp_list);
17627             return ret;
17628         }
17629     }
17630
17631     /* Here, <cp_list> contains all the code points we can determine at
17632      * compile time that match under all conditions.  Go through it, and
17633      * for things that belong in the bitmap, put them there, and delete from
17634      * <cp_list>.  While we are at it, see if everything above 255 is in the
17635      * list, and if so, set a flag to speed up execution */
17636
17637     populate_ANYOF_from_invlist(ret, &cp_list);
17638
17639     if (invert) {
17640         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
17641     }
17642
17643     /* Here, the bitmap has been populated with all the Latin1 code points that
17644      * always match.  Can now add to the overall list those that match only
17645      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
17646      * */
17647     if (has_upper_latin1_only_utf8_matches) {
17648         if (cp_list) {
17649             _invlist_union(cp_list,
17650                            has_upper_latin1_only_utf8_matches,
17651                            &cp_list);
17652             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17653         }
17654         else {
17655             cp_list = has_upper_latin1_only_utf8_matches;
17656         }
17657         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17658     }
17659
17660     /* If there is a swash and more than one element, we can't use the swash in
17661      * the optimization below. */
17662     if (swash && element_count > 1) {
17663         SvREFCNT_dec_NN(swash);
17664         swash = NULL;
17665     }
17666
17667     /* Note that the optimization of using 'swash' if it is the only thing in
17668      * the class doesn't have us change swash at all, so it can include things
17669      * that are also in the bitmap; otherwise we have purposely deleted that
17670      * duplicate information */
17671     set_ANYOF_arg(pRExC_state, ret, cp_list,
17672                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17673                    ? listsv : NULL,
17674                   only_utf8_locale_list,
17675                   swash, has_user_defined_property);
17676
17677     *flagp |= HASWIDTH|SIMPLE;
17678
17679     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
17680         RExC_contains_locale = 1;
17681     }
17682
17683     return ret;
17684 }
17685
17686 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
17687
17688 STATIC void
17689 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
17690                 regnode* const node,
17691                 SV* const cp_list,
17692                 SV* const runtime_defns,
17693                 SV* const only_utf8_locale_list,
17694                 SV* const swash,
17695                 const bool has_user_defined_property)
17696 {
17697     /* Sets the arg field of an ANYOF-type node 'node', using information about
17698      * the node passed-in.  If there is nothing outside the node's bitmap, the
17699      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
17700      * the count returned by add_data(), having allocated and stored an array,
17701      * av, that that count references, as follows:
17702      *  av[0] stores the character class description in its textual form.
17703      *        This is used later (regexec.c:Perl_regclass_swash()) to
17704      *        initialize the appropriate swash, and is also useful for dumping
17705      *        the regnode.  This is set to &PL_sv_undef if the textual
17706      *        description is not needed at run-time (as happens if the other
17707      *        elements completely define the class)
17708      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
17709      *        computed from av[0].  But if no further computation need be done,
17710      *        the swash is stored here now (and av[0] is &PL_sv_undef).
17711      *  av[2] stores the inversion list of code points that match only if the
17712      *        current locale is UTF-8
17713      *  av[3] stores the cp_list inversion list for use in addition or instead
17714      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
17715      *        (Otherwise everything needed is already in av[0] and av[1])
17716      *  av[4] is set if any component of the class is from a user-defined
17717      *        property; used only if av[3] exists */
17718
17719     UV n;
17720
17721     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
17722
17723     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
17724         assert(! (ANYOF_FLAGS(node)
17725                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
17726         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
17727     }
17728     else {
17729         AV * const av = newAV();
17730         SV *rv;
17731
17732         av_store(av, 0, (runtime_defns)
17733                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
17734         if (swash) {
17735             assert(cp_list);
17736             av_store(av, 1, swash);
17737             SvREFCNT_dec_NN(cp_list);
17738         }
17739         else {
17740             av_store(av, 1, &PL_sv_undef);
17741             if (cp_list) {
17742                 av_store(av, 3, cp_list);
17743                 av_store(av, 4, newSVuv(has_user_defined_property));
17744             }
17745         }
17746
17747         if (only_utf8_locale_list) {
17748             av_store(av, 2, only_utf8_locale_list);
17749         }
17750         else {
17751             av_store(av, 2, &PL_sv_undef);
17752         }
17753
17754         rv = newRV_noinc(MUTABLE_SV(av));
17755         n = add_data(pRExC_state, STR_WITH_LEN("s"));
17756         RExC_rxi->data->data[n] = (void*)rv;
17757         ARG_SET(node, n);
17758     }
17759 }
17760
17761 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
17762 SV *
17763 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
17764                                         const regnode* node,
17765                                         bool doinit,
17766                                         SV** listsvp,
17767                                         SV** only_utf8_locale_ptr,
17768                                         SV** output_invlist)
17769
17770 {
17771     /* For internal core use only.
17772      * Returns the swash for the input 'node' in the regex 'prog'.
17773      * If <doinit> is 'true', will attempt to create the swash if not already
17774      *    done.
17775      * If <listsvp> is non-null, will return the printable contents of the
17776      *    swash.  This can be used to get debugging information even before the
17777      *    swash exists, by calling this function with 'doinit' set to false, in
17778      *    which case the components that will be used to eventually create the
17779      *    swash are returned  (in a printable form).
17780      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
17781      *    store an inversion list of code points that should match only if the
17782      *    execution-time locale is a UTF-8 one.
17783      * If <output_invlist> is not NULL, it is where this routine is to store an
17784      *    inversion list of the code points that would be instead returned in
17785      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
17786      *    when this parameter is used, is just the non-code point data that
17787      *    will go into creating the swash.  This currently should be just
17788      *    user-defined properties whose definitions were not known at compile
17789      *    time.  Using this parameter allows for easier manipulation of the
17790      *    swash's data by the caller.  It is illegal to call this function with
17791      *    this parameter set, but not <listsvp>
17792      *
17793      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
17794      * that, in spite of this function's name, the swash it returns may include
17795      * the bitmap data as well */
17796
17797     SV *sw  = NULL;
17798     SV *si  = NULL;         /* Input swash initialization string */
17799     SV* invlist = NULL;
17800
17801     RXi_GET_DECL(prog,progi);
17802     const struct reg_data * const data = prog ? progi->data : NULL;
17803
17804     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
17805     assert(! output_invlist || listsvp);
17806
17807     if (data && data->count) {
17808         const U32 n = ARG(node);
17809
17810         if (data->what[n] == 's') {
17811             SV * const rv = MUTABLE_SV(data->data[n]);
17812             AV * const av = MUTABLE_AV(SvRV(rv));
17813             SV **const ary = AvARRAY(av);
17814             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
17815
17816             si = *ary;  /* ary[0] = the string to initialize the swash with */
17817
17818             if (av_tindex_nomg(av) >= 2) {
17819                 if (only_utf8_locale_ptr
17820                     && ary[2]
17821                     && ary[2] != &PL_sv_undef)
17822                 {
17823                     *only_utf8_locale_ptr = ary[2];
17824                 }
17825                 else {
17826                     assert(only_utf8_locale_ptr);
17827                     *only_utf8_locale_ptr = NULL;
17828                 }
17829
17830                 /* Elements 3 and 4 are either both present or both absent. [3]
17831                  * is any inversion list generated at compile time; [4]
17832                  * indicates if that inversion list has any user-defined
17833                  * properties in it. */
17834                 if (av_tindex_nomg(av) >= 3) {
17835                     invlist = ary[3];
17836                     if (SvUV(ary[4])) {
17837                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
17838                     }
17839                 }
17840                 else {
17841                     invlist = NULL;
17842                 }
17843             }
17844
17845             /* Element [1] is reserved for the set-up swash.  If already there,
17846              * return it; if not, create it and store it there */
17847             if (ary[1] && SvROK(ary[1])) {
17848                 sw = ary[1];
17849             }
17850             else if (doinit && ((si && si != &PL_sv_undef)
17851                                  || (invlist && invlist != &PL_sv_undef))) {
17852                 assert(si);
17853                 sw = _core_swash_init("utf8", /* the utf8 package */
17854                                       "", /* nameless */
17855                                       si,
17856                                       1, /* binary */
17857                                       0, /* not from tr/// */
17858                                       invlist,
17859                                       &swash_init_flags);
17860                 (void)av_store(av, 1, sw);
17861             }
17862         }
17863     }
17864
17865     /* If requested, return a printable version of what this swash matches */
17866     if (listsvp) {
17867         SV* matches_string = NULL;
17868
17869         /* The swash should be used, if possible, to get the data, as it
17870          * contains the resolved data.  But this function can be called at
17871          * compile-time, before everything gets resolved, in which case we
17872          * return the currently best available information, which is the string
17873          * that will eventually be used to do that resolving, 'si' */
17874         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
17875             && (si && si != &PL_sv_undef))
17876         {
17877             /* Here, we only have 'si' (and possibly some passed-in data in
17878              * 'invlist', which is handled below)  If the caller only wants
17879              * 'si', use that.  */
17880             if (! output_invlist) {
17881                 matches_string = newSVsv(si);
17882             }
17883             else {
17884                 /* But if the caller wants an inversion list of the node, we
17885                  * need to parse 'si' and place as much as possible in the
17886                  * desired output inversion list, making 'matches_string' only
17887                  * contain the currently unresolvable things */
17888                 const char *si_string = SvPVX(si);
17889                 STRLEN remaining = SvCUR(si);
17890                 UV prev_cp = 0;
17891                 U8 count = 0;
17892
17893                 /* Ignore everything before the first new-line */
17894                 while (*si_string != '\n' && remaining > 0) {
17895                     si_string++;
17896                     remaining--;
17897                 }
17898                 assert(remaining > 0);
17899
17900                 si_string++;
17901                 remaining--;
17902
17903                 while (remaining > 0) {
17904
17905                     /* The data consists of just strings defining user-defined
17906                      * property names, but in prior incarnations, and perhaps
17907                      * somehow from pluggable regex engines, it could still
17908                      * hold hex code point definitions.  Each component of a
17909                      * range would be separated by a tab, and each range by a
17910                      * new-line.  If these are found, instead add them to the
17911                      * inversion list */
17912                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
17913                                      |PERL_SCAN_SILENT_NON_PORTABLE;
17914                     STRLEN len = remaining;
17915                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
17916
17917                     /* If the hex decode routine found something, it should go
17918                      * up to the next \n */
17919                     if (   *(si_string + len) == '\n') {
17920                         if (count) {    /* 2nd code point on line */
17921                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
17922                         }
17923                         else {
17924                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
17925                         }
17926                         count = 0;
17927                         goto prepare_for_next_iteration;
17928                     }
17929
17930                     /* If the hex decode was instead for the lower range limit,
17931                      * save it, and go parse the upper range limit */
17932                     if (*(si_string + len) == '\t') {
17933                         assert(count == 0);
17934
17935                         prev_cp = cp;
17936                         count = 1;
17937                       prepare_for_next_iteration:
17938                         si_string += len + 1;
17939                         remaining -= len + 1;
17940                         continue;
17941                     }
17942
17943                     /* Here, didn't find a legal hex number.  Just add it from
17944                      * here to the next \n */
17945
17946                     remaining -= len;
17947                     while (*(si_string + len) != '\n' && remaining > 0) {
17948                         remaining--;
17949                         len++;
17950                     }
17951                     if (*(si_string + len) == '\n') {
17952                         len++;
17953                         remaining--;
17954                     }
17955                     if (matches_string) {
17956                         sv_catpvn(matches_string, si_string, len - 1);
17957                     }
17958                     else {
17959                         matches_string = newSVpvn(si_string, len - 1);
17960                     }
17961                     si_string += len;
17962                     sv_catpvs(matches_string, " ");
17963                 } /* end of loop through the text */
17964
17965                 assert(matches_string);
17966                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
17967                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
17968                 }
17969             } /* end of has an 'si' but no swash */
17970         }
17971
17972         /* If we have a swash in place, its equivalent inversion list was above
17973          * placed into 'invlist'.  If not, this variable may contain a stored
17974          * inversion list which is information beyond what is in 'si' */
17975         if (invlist) {
17976
17977             /* Again, if the caller doesn't want the output inversion list, put
17978              * everything in 'matches-string' */
17979             if (! output_invlist) {
17980                 if ( ! matches_string) {
17981                     matches_string = newSVpvs("\n");
17982                 }
17983                 sv_catsv(matches_string, invlist_contents(invlist,
17984                                                   TRUE /* traditional style */
17985                                                   ));
17986             }
17987             else if (! *output_invlist) {
17988                 *output_invlist = invlist_clone(invlist);
17989             }
17990             else {
17991                 _invlist_union(*output_invlist, invlist, output_invlist);
17992             }
17993         }
17994
17995         *listsvp = matches_string;
17996     }
17997
17998     return sw;
17999 }
18000 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18001
18002 /* reg_skipcomment()
18003
18004    Absorbs an /x style # comment from the input stream,
18005    returning a pointer to the first character beyond the comment, or if the
18006    comment terminates the pattern without anything following it, this returns
18007    one past the final character of the pattern (in other words, RExC_end) and
18008    sets the REG_RUN_ON_COMMENT_SEEN flag.
18009
18010    Note it's the callers responsibility to ensure that we are
18011    actually in /x mode
18012
18013 */
18014
18015 PERL_STATIC_INLINE char*
18016 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18017 {
18018     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18019
18020     assert(*p == '#');
18021
18022     while (p < RExC_end) {
18023         if (*(++p) == '\n') {
18024             return p+1;
18025         }
18026     }
18027
18028     /* we ran off the end of the pattern without ending the comment, so we have
18029      * to add an \n when wrapping */
18030     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18031     return p;
18032 }
18033
18034 STATIC void
18035 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18036                                 char ** p,
18037                                 const bool force_to_xmod
18038                          )
18039 {
18040     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18041      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18042      * is /x whitespace, advance '*p' so that on exit it points to the first
18043      * byte past all such white space and comments */
18044
18045     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18046
18047     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18048
18049     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18050
18051     for (;;) {
18052         if (RExC_end - (*p) >= 3
18053             && *(*p)     == '('
18054             && *(*p + 1) == '?'
18055             && *(*p + 2) == '#')
18056         {
18057             while (*(*p) != ')') {
18058                 if ((*p) == RExC_end)
18059                     FAIL("Sequence (?#... not terminated");
18060                 (*p)++;
18061             }
18062             (*p)++;
18063             continue;
18064         }
18065
18066         if (use_xmod) {
18067             const char * save_p = *p;
18068             while ((*p) < RExC_end) {
18069                 STRLEN len;
18070                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18071                     (*p) += len;
18072                 }
18073                 else if (*(*p) == '#') {
18074                     (*p) = reg_skipcomment(pRExC_state, (*p));
18075                 }
18076                 else {
18077                     break;
18078                 }
18079             }
18080             if (*p != save_p) {
18081                 continue;
18082             }
18083         }
18084
18085         break;
18086     }
18087
18088     return;
18089 }
18090
18091 /* nextchar()
18092
18093    Advances the parse position by one byte, unless that byte is the beginning
18094    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
18095    those two cases, the parse position is advanced beyond all such comments and
18096    white space.
18097
18098    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
18099 */
18100
18101 STATIC void
18102 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
18103 {
18104     PERL_ARGS_ASSERT_NEXTCHAR;
18105
18106     if (RExC_parse < RExC_end) {
18107         assert(   ! UTF
18108                || UTF8_IS_INVARIANT(*RExC_parse)
18109                || UTF8_IS_START(*RExC_parse));
18110
18111         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
18112
18113         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
18114                                 FALSE /* Don't assume /x */ );
18115     }
18116 }
18117
18118 STATIC regnode *
18119 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
18120 {
18121     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
18122      * space.  In pass1, it aligns and increments RExC_size; in pass2,
18123      * RExC_emit */
18124
18125     regnode * const ret = RExC_emit;
18126     GET_RE_DEBUG_FLAGS_DECL;
18127
18128     PERL_ARGS_ASSERT_REGNODE_GUTS;
18129
18130     assert(extra_size >= regarglen[op]);
18131
18132     if (SIZE_ONLY) {
18133         SIZE_ALIGN(RExC_size);
18134         RExC_size += 1 + extra_size;
18135         return(ret);
18136     }
18137     if (RExC_emit >= RExC_emit_bound)
18138         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
18139                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
18140
18141     NODE_ALIGN_FILL(ret);
18142 #ifndef RE_TRACK_PATTERN_OFFSETS
18143     PERL_UNUSED_ARG(name);
18144 #else
18145     if (RExC_offsets) {         /* MJD */
18146         MJD_OFFSET_DEBUG(
18147               ("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
18148               name, __LINE__,
18149               PL_reg_name[op],
18150               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
18151                 ? "Overwriting end of array!\n" : "OK",
18152               (UV)(RExC_emit - RExC_emit_start),
18153               (UV)(RExC_parse - RExC_start),
18154               (UV)RExC_offsets[0]));
18155         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
18156     }
18157 #endif
18158     return(ret);
18159 }
18160
18161 /*
18162 - reg_node - emit a node
18163 */
18164 STATIC regnode *                        /* Location. */
18165 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
18166 {
18167     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
18168
18169     PERL_ARGS_ASSERT_REG_NODE;
18170
18171     assert(regarglen[op] == 0);
18172
18173     if (PASS2) {
18174         regnode *ptr = ret;
18175         FILL_ADVANCE_NODE(ptr, op);
18176         RExC_emit = ptr;
18177     }
18178     return(ret);
18179 }
18180
18181 /*
18182 - reganode - emit a node with an argument
18183 */
18184 STATIC regnode *                        /* Location. */
18185 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
18186 {
18187     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
18188
18189     PERL_ARGS_ASSERT_REGANODE;
18190
18191     assert(regarglen[op] == 1);
18192
18193     if (PASS2) {
18194         regnode *ptr = ret;
18195         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
18196         RExC_emit = ptr;
18197     }
18198     return(ret);
18199 }
18200
18201 STATIC regnode *
18202 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
18203 {
18204     /* emit a node with U32 and I32 arguments */
18205
18206     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
18207
18208     PERL_ARGS_ASSERT_REG2LANODE;
18209
18210     assert(regarglen[op] == 2);
18211
18212     if (PASS2) {
18213         regnode *ptr = ret;
18214         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
18215         RExC_emit = ptr;
18216     }
18217     return(ret);
18218 }
18219
18220 /*
18221 - reginsert - insert an operator in front of already-emitted operand
18222 *
18223 * Means relocating the operand.
18224 */
18225 STATIC void
18226 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
18227 {
18228     regnode *src;
18229     regnode *dst;
18230     regnode *place;
18231     const int offset = regarglen[(U8)op];
18232     const int size = NODE_STEP_REGNODE + offset;
18233     GET_RE_DEBUG_FLAGS_DECL;
18234
18235     PERL_ARGS_ASSERT_REGINSERT;
18236     PERL_UNUSED_CONTEXT;
18237     PERL_UNUSED_ARG(depth);
18238 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
18239     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
18240     if (SIZE_ONLY) {
18241         RExC_size += size;
18242         return;
18243     }
18244
18245     src = RExC_emit;
18246     RExC_emit += size;
18247     dst = RExC_emit;
18248     if (RExC_open_parens) {
18249         int paren;
18250         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
18251         /* remember that RExC_npar is rex->nparens + 1,
18252          * iow it is 1 more than the number of parens seen in
18253          * the pattern so far. */
18254         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
18255             if ( RExC_open_parens[paren] >= opnd ) {
18256                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
18257                 RExC_open_parens[paren] += size;
18258             } else {
18259                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
18260             }
18261             if ( RExC_close_parens[paren] >= opnd ) {
18262                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
18263                 RExC_close_parens[paren] += size;
18264             } else {
18265                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
18266             }
18267         }
18268     }
18269     if (RExC_end_op)
18270         RExC_end_op += size;
18271
18272     while (src > opnd) {
18273         StructCopy(--src, --dst, regnode);
18274 #ifdef RE_TRACK_PATTERN_OFFSETS
18275         if (RExC_offsets) {     /* MJD 20010112 */
18276             MJD_OFFSET_DEBUG(
18277                  ("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
18278                   "reg_insert",
18279                   __LINE__,
18280                   PL_reg_name[op],
18281                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
18282                     ? "Overwriting end of array!\n" : "OK",
18283                   (UV)(src - RExC_emit_start),
18284                   (UV)(dst - RExC_emit_start),
18285                   (UV)RExC_offsets[0]));
18286             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
18287             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
18288         }
18289 #endif
18290     }
18291
18292
18293     place = opnd;               /* Op node, where operand used to be. */
18294 #ifdef RE_TRACK_PATTERN_OFFSETS
18295     if (RExC_offsets) {         /* MJD */
18296         MJD_OFFSET_DEBUG(
18297               ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
18298               "reginsert",
18299               __LINE__,
18300               PL_reg_name[op],
18301               (UV)(place - RExC_emit_start) > RExC_offsets[0]
18302               ? "Overwriting end of array!\n" : "OK",
18303               (UV)(place - RExC_emit_start),
18304               (UV)(RExC_parse - RExC_start),
18305               (UV)RExC_offsets[0]));
18306         Set_Node_Offset(place, RExC_parse);
18307         Set_Node_Length(place, 1);
18308     }
18309 #endif
18310     src = NEXTOPER(place);
18311     FILL_ADVANCE_NODE(place, op);
18312     Zero(src, offset, regnode);
18313 }
18314
18315 /*
18316 - regtail - set the next-pointer at the end of a node chain of p to val.
18317 - SEE ALSO: regtail_study
18318 */
18319 STATIC void
18320 S_regtail(pTHX_ RExC_state_t * pRExC_state,
18321                 const regnode * const p,
18322                 const regnode * const val,
18323                 const U32 depth)
18324 {
18325     regnode *scan;
18326     GET_RE_DEBUG_FLAGS_DECL;
18327
18328     PERL_ARGS_ASSERT_REGTAIL;
18329 #ifndef DEBUGGING
18330     PERL_UNUSED_ARG(depth);
18331 #endif
18332
18333     if (SIZE_ONLY)
18334         return;
18335
18336     /* Find last node. */
18337     scan = (regnode *) p;
18338     for (;;) {
18339         regnode * const temp = regnext(scan);
18340         DEBUG_PARSE_r({
18341             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
18342             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18343             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
18344                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
18345                     (temp == NULL ? "->" : ""),
18346                     (temp == NULL ? PL_reg_name[OP(val)] : "")
18347             );
18348         });
18349         if (temp == NULL)
18350             break;
18351         scan = temp;
18352     }
18353
18354     if (reg_off_by_arg[OP(scan)]) {
18355         ARG_SET(scan, val - scan);
18356     }
18357     else {
18358         NEXT_OFF(scan) = val - scan;
18359     }
18360 }
18361
18362 #ifdef DEBUGGING
18363 /*
18364 - regtail_study - set the next-pointer at the end of a node chain of p to val.
18365 - Look for optimizable sequences at the same time.
18366 - currently only looks for EXACT chains.
18367
18368 This is experimental code. The idea is to use this routine to perform
18369 in place optimizations on branches and groups as they are constructed,
18370 with the long term intention of removing optimization from study_chunk so
18371 that it is purely analytical.
18372
18373 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
18374 to control which is which.
18375
18376 */
18377 /* TODO: All four parms should be const */
18378
18379 STATIC U8
18380 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
18381                       const regnode *val,U32 depth)
18382 {
18383     regnode *scan;
18384     U8 exact = PSEUDO;
18385 #ifdef EXPERIMENTAL_INPLACESCAN
18386     I32 min = 0;
18387 #endif
18388     GET_RE_DEBUG_FLAGS_DECL;
18389
18390     PERL_ARGS_ASSERT_REGTAIL_STUDY;
18391
18392
18393     if (SIZE_ONLY)
18394         return exact;
18395
18396     /* Find last node. */
18397
18398     scan = p;
18399     for (;;) {
18400         regnode * const temp = regnext(scan);
18401 #ifdef EXPERIMENTAL_INPLACESCAN
18402         if (PL_regkind[OP(scan)] == EXACT) {
18403             bool unfolded_multi_char;   /* Unexamined in this routine */
18404             if (join_exact(pRExC_state, scan, &min,
18405                            &unfolded_multi_char, 1, val, depth+1))
18406                 return EXACT;
18407         }
18408 #endif
18409         if ( exact ) {
18410             switch (OP(scan)) {
18411                 case EXACT:
18412                 case EXACTL:
18413                 case EXACTF:
18414                 case EXACTFA_NO_TRIE:
18415                 case EXACTFA:
18416                 case EXACTFU:
18417                 case EXACTFLU8:
18418                 case EXACTFU_SS:
18419                 case EXACTFL:
18420                         if( exact == PSEUDO )
18421                             exact= OP(scan);
18422                         else if ( exact != OP(scan) )
18423                             exact= 0;
18424                 case NOTHING:
18425                     break;
18426                 default:
18427                     exact= 0;
18428             }
18429         }
18430         DEBUG_PARSE_r({
18431             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
18432             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18433             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
18434                 SvPV_nolen_const(RExC_mysv),
18435                 REG_NODE_NUM(scan),
18436                 PL_reg_name[exact]);
18437         });
18438         if (temp == NULL)
18439             break;
18440         scan = temp;
18441     }
18442     DEBUG_PARSE_r({
18443         DEBUG_PARSE_MSG("");
18444         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
18445         Perl_re_printf( aTHX_
18446                       "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
18447                       SvPV_nolen_const(RExC_mysv),
18448                       (IV)REG_NODE_NUM(val),
18449                       (IV)(val - scan)
18450         );
18451     });
18452     if (reg_off_by_arg[OP(scan)]) {
18453         ARG_SET(scan, val - scan);
18454     }
18455     else {
18456         NEXT_OFF(scan) = val - scan;
18457     }
18458
18459     return exact;
18460 }
18461 #endif
18462
18463 /*
18464  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
18465  */
18466 #ifdef DEBUGGING
18467
18468 static void
18469 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
18470 {
18471     int bit;
18472     int set=0;
18473
18474     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18475
18476     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
18477         if (flags & (1<<bit)) {
18478             if (!set++ && lead)
18479                 Perl_re_printf( aTHX_  "%s",lead);
18480             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
18481         }
18482     }
18483     if (lead)  {
18484         if (set)
18485             Perl_re_printf( aTHX_  "\n");
18486         else
18487             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18488     }
18489 }
18490
18491 static void
18492 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
18493 {
18494     int bit;
18495     int set=0;
18496     regex_charset cs;
18497
18498     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18499
18500     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
18501         if (flags & (1<<bit)) {
18502             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
18503                 continue;
18504             }
18505             if (!set++ && lead)
18506                 Perl_re_printf( aTHX_  "%s",lead);
18507             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
18508         }
18509     }
18510     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
18511             if (!set++ && lead) {
18512                 Perl_re_printf( aTHX_  "%s",lead);
18513             }
18514             switch (cs) {
18515                 case REGEX_UNICODE_CHARSET:
18516                     Perl_re_printf( aTHX_  "UNICODE");
18517                     break;
18518                 case REGEX_LOCALE_CHARSET:
18519                     Perl_re_printf( aTHX_  "LOCALE");
18520                     break;
18521                 case REGEX_ASCII_RESTRICTED_CHARSET:
18522                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
18523                     break;
18524                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
18525                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
18526                     break;
18527                 default:
18528                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
18529                     break;
18530             }
18531     }
18532     if (lead)  {
18533         if (set)
18534             Perl_re_printf( aTHX_  "\n");
18535         else
18536             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18537     }
18538 }
18539 #endif
18540
18541 void
18542 Perl_regdump(pTHX_ const regexp *r)
18543 {
18544 #ifdef DEBUGGING
18545     SV * const sv = sv_newmortal();
18546     SV *dsv= sv_newmortal();
18547     RXi_GET_DECL(r,ri);
18548     GET_RE_DEBUG_FLAGS_DECL;
18549
18550     PERL_ARGS_ASSERT_REGDUMP;
18551
18552     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
18553
18554     /* Header fields of interest. */
18555     if (r->anchored_substr) {
18556         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
18557             RE_SV_DUMPLEN(r->anchored_substr), 30);
18558         Perl_re_printf( aTHX_
18559                       "anchored %s%s at %"IVdf" ",
18560                       s, RE_SV_TAIL(r->anchored_substr),
18561                       (IV)r->anchored_offset);
18562     } else if (r->anchored_utf8) {
18563         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
18564             RE_SV_DUMPLEN(r->anchored_utf8), 30);
18565         Perl_re_printf( aTHX_
18566                       "anchored utf8 %s%s at %"IVdf" ",
18567                       s, RE_SV_TAIL(r->anchored_utf8),
18568                       (IV)r->anchored_offset);
18569     }
18570     if (r->float_substr) {
18571         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
18572             RE_SV_DUMPLEN(r->float_substr), 30);
18573         Perl_re_printf( aTHX_
18574                       "floating %s%s at %"IVdf"..%"UVuf" ",
18575                       s, RE_SV_TAIL(r->float_substr),
18576                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18577     } else if (r->float_utf8) {
18578         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
18579             RE_SV_DUMPLEN(r->float_utf8), 30);
18580         Perl_re_printf( aTHX_
18581                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
18582                       s, RE_SV_TAIL(r->float_utf8),
18583                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18584     }
18585     if (r->check_substr || r->check_utf8)
18586         Perl_re_printf( aTHX_
18587                       (const char *)
18588                       (r->check_substr == r->float_substr
18589                        && r->check_utf8 == r->float_utf8
18590                        ? "(checking floating" : "(checking anchored"));
18591     if (r->intflags & PREGf_NOSCAN)
18592         Perl_re_printf( aTHX_  " noscan");
18593     if (r->extflags & RXf_CHECK_ALL)
18594         Perl_re_printf( aTHX_  " isall");
18595     if (r->check_substr || r->check_utf8)
18596         Perl_re_printf( aTHX_  ") ");
18597
18598     if (ri->regstclass) {
18599         regprop(r, sv, ri->regstclass, NULL, NULL);
18600         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
18601     }
18602     if (r->intflags & PREGf_ANCH) {
18603         Perl_re_printf( aTHX_  "anchored");
18604         if (r->intflags & PREGf_ANCH_MBOL)
18605             Perl_re_printf( aTHX_  "(MBOL)");
18606         if (r->intflags & PREGf_ANCH_SBOL)
18607             Perl_re_printf( aTHX_  "(SBOL)");
18608         if (r->intflags & PREGf_ANCH_GPOS)
18609             Perl_re_printf( aTHX_  "(GPOS)");
18610         Perl_re_printf( aTHX_ " ");
18611     }
18612     if (r->intflags & PREGf_GPOS_SEEN)
18613         Perl_re_printf( aTHX_  "GPOS:%"UVuf" ", (UV)r->gofs);
18614     if (r->intflags & PREGf_SKIP)
18615         Perl_re_printf( aTHX_  "plus ");
18616     if (r->intflags & PREGf_IMPLICIT)
18617         Perl_re_printf( aTHX_  "implicit ");
18618     Perl_re_printf( aTHX_  "minlen %"IVdf" ", (IV)r->minlen);
18619     if (r->extflags & RXf_EVAL_SEEN)
18620         Perl_re_printf( aTHX_  "with eval ");
18621     Perl_re_printf( aTHX_  "\n");
18622     DEBUG_FLAGS_r({
18623         regdump_extflags("r->extflags: ",r->extflags);
18624         regdump_intflags("r->intflags: ",r->intflags);
18625     });
18626 #else
18627     PERL_ARGS_ASSERT_REGDUMP;
18628     PERL_UNUSED_CONTEXT;
18629     PERL_UNUSED_ARG(r);
18630 #endif  /* DEBUGGING */
18631 }
18632
18633 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
18634 #ifdef DEBUGGING
18635
18636 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
18637      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
18638      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
18639      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
18640      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
18641      || _CC_VERTSPACE != 15
18642 #   error Need to adjust order of anyofs[]
18643 #  endif
18644 static const char * const anyofs[] = {
18645     "\\w",
18646     "\\W",
18647     "\\d",
18648     "\\D",
18649     "[:alpha:]",
18650     "[:^alpha:]",
18651     "[:lower:]",
18652     "[:^lower:]",
18653     "[:upper:]",
18654     "[:^upper:]",
18655     "[:punct:]",
18656     "[:^punct:]",
18657     "[:print:]",
18658     "[:^print:]",
18659     "[:alnum:]",
18660     "[:^alnum:]",
18661     "[:graph:]",
18662     "[:^graph:]",
18663     "[:cased:]",
18664     "[:^cased:]",
18665     "\\s",
18666     "\\S",
18667     "[:blank:]",
18668     "[:^blank:]",
18669     "[:xdigit:]",
18670     "[:^xdigit:]",
18671     "[:cntrl:]",
18672     "[:^cntrl:]",
18673     "[:ascii:]",
18674     "[:^ascii:]",
18675     "\\v",
18676     "\\V"
18677 };
18678 #endif
18679
18680 /*
18681 - regprop - printable representation of opcode, with run time support
18682 */
18683
18684 void
18685 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
18686 {
18687 #ifdef DEBUGGING
18688     int k;
18689     RXi_GET_DECL(prog,progi);
18690     GET_RE_DEBUG_FLAGS_DECL;
18691
18692     PERL_ARGS_ASSERT_REGPROP;
18693
18694     sv_setpvn(sv, "", 0);
18695
18696     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
18697         /* It would be nice to FAIL() here, but this may be called from
18698            regexec.c, and it would be hard to supply pRExC_state. */
18699         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
18700                                               (int)OP(o), (int)REGNODE_MAX);
18701     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
18702
18703     k = PL_regkind[OP(o)];
18704
18705     if (k == EXACT) {
18706         sv_catpvs(sv, " ");
18707         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
18708          * is a crude hack but it may be the best for now since
18709          * we have no flag "this EXACTish node was UTF-8"
18710          * --jhi */
18711         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
18712                   PERL_PV_ESCAPE_UNI_DETECT |
18713                   PERL_PV_ESCAPE_NONASCII   |
18714                   PERL_PV_PRETTY_ELLIPSES   |
18715                   PERL_PV_PRETTY_LTGT       |
18716                   PERL_PV_PRETTY_NOCLEAR
18717                   );
18718     } else if (k == TRIE) {
18719         /* print the details of the trie in dumpuntil instead, as
18720          * progi->data isn't available here */
18721         const char op = OP(o);
18722         const U32 n = ARG(o);
18723         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
18724                (reg_ac_data *)progi->data->data[n] :
18725                NULL;
18726         const reg_trie_data * const trie
18727             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
18728
18729         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
18730         DEBUG_TRIE_COMPILE_r(
18731           Perl_sv_catpvf(aTHX_ sv,
18732             "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
18733             (UV)trie->startstate,
18734             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
18735             (UV)trie->wordcount,
18736             (UV)trie->minlen,
18737             (UV)trie->maxlen,
18738             (UV)TRIE_CHARCOUNT(trie),
18739             (UV)trie->uniquecharcount
18740           );
18741         );
18742         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
18743             sv_catpvs(sv, "[");
18744             (void) put_charclass_bitmap_innards(sv,
18745                                                 ((IS_ANYOF_TRIE(op))
18746                                                  ? ANYOF_BITMAP(o)
18747                                                  : TRIE_BITMAP(trie)),
18748                                                 NULL,
18749                                                 NULL,
18750                                                 NULL
18751                                                );
18752             sv_catpvs(sv, "]");
18753         }
18754
18755     } else if (k == CURLY) {
18756         U32 lo = ARG1(o), hi = ARG2(o);
18757         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
18758             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
18759         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
18760         if (hi == REG_INFTY)
18761             sv_catpvs(sv, "INFTY");
18762         else
18763             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
18764         sv_catpvs(sv, "}");
18765     }
18766     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
18767         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
18768     else if (k == REF || k == OPEN || k == CLOSE
18769              || k == GROUPP || OP(o)==ACCEPT)
18770     {
18771         AV *name_list= NULL;
18772         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
18773         Perl_sv_catpvf(aTHX_ sv, "%"UVuf, (UV)parno);        /* Parenth number */
18774         if ( RXp_PAREN_NAMES(prog) ) {
18775             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
18776         } else if ( pRExC_state ) {
18777             name_list= RExC_paren_name_list;
18778         }
18779         if (name_list) {
18780             if ( k != REF || (OP(o) < NREF)) {
18781                 SV **name= av_fetch(name_list, parno, 0 );
18782                 if (name)
18783                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
18784             }
18785             else {
18786                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
18787                 I32 *nums=(I32*)SvPVX(sv_dat);
18788                 SV **name= av_fetch(name_list, nums[0], 0 );
18789                 I32 n;
18790                 if (name) {
18791                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
18792                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
18793                                     (n ? "," : ""), (IV)nums[n]);
18794                     }
18795                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
18796                 }
18797             }
18798         }
18799         if ( k == REF && reginfo) {
18800             U32 n = ARG(o);  /* which paren pair */
18801             I32 ln = prog->offs[n].start;
18802             if (prog->lastparen < n || ln == -1)
18803                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
18804             else if (ln == prog->offs[n].end)
18805                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
18806             else {
18807                 const char *s = reginfo->strbeg + ln;
18808                 Perl_sv_catpvf(aTHX_ sv, ": ");
18809                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
18810                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
18811             }
18812         }
18813     } else if (k == GOSUB) {
18814         AV *name_list= NULL;
18815         if ( RXp_PAREN_NAMES(prog) ) {
18816             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
18817         } else if ( pRExC_state ) {
18818             name_list= RExC_paren_name_list;
18819         }
18820
18821         /* Paren and offset */
18822         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
18823                 (int)((o + (int)ARG2L(o)) - progi->program) );
18824         if (name_list) {
18825             SV **name= av_fetch(name_list, ARG(o), 0 );
18826             if (name)
18827                 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
18828         }
18829     }
18830     else if (k == LOGICAL)
18831         /* 2: embedded, otherwise 1 */
18832         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
18833     else if (k == ANYOF) {
18834         const U8 flags = ANYOF_FLAGS(o);
18835         bool do_sep = FALSE;    /* Do we need to separate various components of
18836                                    the output? */
18837         /* Set if there is still an unresolved user-defined property */
18838         SV *unresolved                = NULL;
18839
18840         /* Things that are ignored except when the runtime locale is UTF-8 */
18841         SV *only_utf8_locale_invlist = NULL;
18842
18843         /* Code points that don't fit in the bitmap */
18844         SV *nonbitmap_invlist = NULL;
18845
18846         /* And things that aren't in the bitmap, but are small enough to be */
18847         SV* bitmap_range_not_in_bitmap = NULL;
18848
18849         if (OP(o) == ANYOFL) {
18850             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
18851                 sv_catpvs(sv, "{utf8-locale-reqd}");
18852             }
18853             if (flags & ANYOFL_FOLD) {
18854                 sv_catpvs(sv, "{i}");
18855             }
18856         }
18857
18858         /* If there is stuff outside the bitmap, get it */
18859         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
18860             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
18861                                                 &unresolved,
18862                                                 &only_utf8_locale_invlist,
18863                                                 &nonbitmap_invlist);
18864             /* The non-bitmap data may contain stuff that could fit in the
18865              * bitmap.  This could come from a user-defined property being
18866              * finally resolved when this call was done; or much more likely
18867              * because there are matches that require UTF-8 to be valid, and so
18868              * aren't in the bitmap.  This is teased apart later */
18869             _invlist_intersection(nonbitmap_invlist,
18870                                   PL_InBitmap,
18871                                   &bitmap_range_not_in_bitmap);
18872             /* Leave just the things that don't fit into the bitmap */
18873             _invlist_subtract(nonbitmap_invlist,
18874                               PL_InBitmap,
18875                               &nonbitmap_invlist);
18876         }
18877
18878         /* Obey this flag to add all above-the-bitmap code points */
18879         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
18880             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
18881                                                       NUM_ANYOF_CODE_POINTS,
18882                                                       UV_MAX);
18883         }
18884
18885         /* Ready to start outputting.  First, the initial left bracket */
18886         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
18887
18888         /* Then all the things that could fit in the bitmap */
18889         do_sep = put_charclass_bitmap_innards(sv,
18890                                               ANYOF_BITMAP(o),
18891                                               bitmap_range_not_in_bitmap,
18892                                               only_utf8_locale_invlist,
18893                                               o);
18894         SvREFCNT_dec(bitmap_range_not_in_bitmap);
18895
18896         /* If there are user-defined properties which haven't been defined yet,
18897          * output them, in a separate [] from the bitmap range stuff */
18898         if (unresolved) {
18899             if (do_sep) {
18900                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
18901             }
18902             if (flags & ANYOF_INVERT) {
18903                 sv_catpvs(sv, "^");
18904             }
18905             sv_catsv(sv, unresolved);
18906             do_sep = TRUE;
18907             SvREFCNT_dec_NN(unresolved);
18908         }
18909
18910         /* And, finally, add the above-the-bitmap stuff */
18911         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
18912             SV* contents;
18913
18914             /* See if truncation size is overridden */
18915             const STRLEN dump_len = (PL_dump_re_max_len)
18916                                     ? PL_dump_re_max_len
18917                                     : 256;
18918
18919             /* This is output in a separate [] */
18920             if (do_sep) {
18921                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
18922             }
18923
18924             /* And, for easy of understanding, it is always output not-shown as
18925              * complemented */
18926             if (flags & ANYOF_INVERT) {
18927                 _invlist_invert(nonbitmap_invlist);
18928                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
18929             }
18930
18931             contents = invlist_contents(nonbitmap_invlist,
18932                                         FALSE /* output suitable for catsv */
18933                                        );
18934
18935             /* If the output is shorter than the permissible maximum, just do it. */
18936             if (SvCUR(contents) <= dump_len) {
18937                 sv_catsv(sv, contents);
18938             }
18939             else {
18940                 const char * contents_string = SvPVX(contents);
18941                 STRLEN i = dump_len;
18942
18943                 /* Otherwise, start at the permissible max and work back to the
18944                  * first break possibility */
18945                 while (i > 0 && contents_string[i] != ' ') {
18946                     i--;
18947                 }
18948                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
18949                                        find a legal break */
18950                     i = dump_len;
18951                 }
18952
18953                 sv_catpvn(sv, contents_string, i);
18954                 sv_catpvs(sv, "...");
18955             }
18956
18957             SvREFCNT_dec_NN(contents);
18958             SvREFCNT_dec_NN(nonbitmap_invlist);
18959         }
18960
18961         /* And finally the matching, closing ']' */
18962         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
18963     }
18964     else if (k == POSIXD || k == NPOSIXD) {
18965         U8 index = FLAGS(o) * 2;
18966         if (index < C_ARRAY_LENGTH(anyofs)) {
18967             if (*anyofs[index] != '[')  {
18968                 sv_catpv(sv, "[");
18969             }
18970             sv_catpv(sv, anyofs[index]);
18971             if (*anyofs[index] != '[')  {
18972                 sv_catpv(sv, "]");
18973             }
18974         }
18975         else {
18976             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
18977         }
18978     }
18979     else if (k == BOUND || k == NBOUND) {
18980         /* Must be synced with order of 'bound_type' in regcomp.h */
18981         const char * const bounds[] = {
18982             "",      /* Traditional */
18983             "{gcb}",
18984             "{lb}",
18985             "{sb}",
18986             "{wb}"
18987         };
18988         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
18989         sv_catpv(sv, bounds[FLAGS(o)]);
18990     }
18991     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
18992         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
18993     else if (OP(o) == SBOL)
18994         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
18995
18996     /* add on the verb argument if there is one */
18997     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
18998         Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
18999                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
19000     }
19001 #else
19002     PERL_UNUSED_CONTEXT;
19003     PERL_UNUSED_ARG(sv);
19004     PERL_UNUSED_ARG(o);
19005     PERL_UNUSED_ARG(prog);
19006     PERL_UNUSED_ARG(reginfo);
19007     PERL_UNUSED_ARG(pRExC_state);
19008 #endif  /* DEBUGGING */
19009 }
19010
19011
19012
19013 SV *
19014 Perl_re_intuit_string(pTHX_ REGEXP * const r)
19015 {                               /* Assume that RE_INTUIT is set */
19016     struct regexp *const prog = ReANY(r);
19017     GET_RE_DEBUG_FLAGS_DECL;
19018
19019     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
19020     PERL_UNUSED_CONTEXT;
19021
19022     DEBUG_COMPILE_r(
19023         {
19024             const char * const s = SvPV_nolen_const(RX_UTF8(r)
19025                       ? prog->check_utf8 : prog->check_substr);
19026
19027             if (!PL_colorset) reginitcolors();
19028             Perl_re_printf( aTHX_
19029                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
19030                       PL_colors[4],
19031                       RX_UTF8(r) ? "utf8 " : "",
19032                       PL_colors[5],PL_colors[0],
19033                       s,
19034                       PL_colors[1],
19035                       (strlen(s) > 60 ? "..." : ""));
19036         } );
19037
19038     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
19039     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
19040 }
19041
19042 /*
19043    pregfree()
19044
19045    handles refcounting and freeing the perl core regexp structure. When
19046    it is necessary to actually free the structure the first thing it
19047    does is call the 'free' method of the regexp_engine associated to
19048    the regexp, allowing the handling of the void *pprivate; member
19049    first. (This routine is not overridable by extensions, which is why
19050    the extensions free is called first.)
19051
19052    See regdupe and regdupe_internal if you change anything here.
19053 */
19054 #ifndef PERL_IN_XSUB_RE
19055 void
19056 Perl_pregfree(pTHX_ REGEXP *r)
19057 {
19058     SvREFCNT_dec(r);
19059 }
19060
19061 void
19062 Perl_pregfree2(pTHX_ REGEXP *rx)
19063 {
19064     struct regexp *const r = ReANY(rx);
19065     GET_RE_DEBUG_FLAGS_DECL;
19066
19067     PERL_ARGS_ASSERT_PREGFREE2;
19068
19069     if (r->mother_re) {
19070         ReREFCNT_dec(r->mother_re);
19071     } else {
19072         CALLREGFREE_PVT(rx); /* free the private data */
19073         SvREFCNT_dec(RXp_PAREN_NAMES(r));
19074         Safefree(r->xpv_len_u.xpvlenu_pv);
19075     }
19076     if (r->substrs) {
19077         SvREFCNT_dec(r->anchored_substr);
19078         SvREFCNT_dec(r->anchored_utf8);
19079         SvREFCNT_dec(r->float_substr);
19080         SvREFCNT_dec(r->float_utf8);
19081         Safefree(r->substrs);
19082     }
19083     RX_MATCH_COPY_FREE(rx);
19084 #ifdef PERL_ANY_COW
19085     SvREFCNT_dec(r->saved_copy);
19086 #endif
19087     Safefree(r->offs);
19088     SvREFCNT_dec(r->qr_anoncv);
19089     if (r->recurse_locinput)
19090         Safefree(r->recurse_locinput);
19091     rx->sv_u.svu_rx = 0;
19092 }
19093
19094 /*  reg_temp_copy()
19095
19096     This is a hacky workaround to the structural issue of match results
19097     being stored in the regexp structure which is in turn stored in
19098     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
19099     could be PL_curpm in multiple contexts, and could require multiple
19100     result sets being associated with the pattern simultaneously, such
19101     as when doing a recursive match with (??{$qr})
19102
19103     The solution is to make a lightweight copy of the regexp structure
19104     when a qr// is returned from the code executed by (??{$qr}) this
19105     lightweight copy doesn't actually own any of its data except for
19106     the starp/end and the actual regexp structure itself.
19107
19108 */
19109
19110
19111 REGEXP *
19112 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
19113 {
19114     struct regexp *ret;
19115     struct regexp *const r = ReANY(rx);
19116     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
19117
19118     PERL_ARGS_ASSERT_REG_TEMP_COPY;
19119
19120     if (!ret_x)
19121         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
19122     else {
19123         SvOK_off((SV *)ret_x);
19124         if (islv) {
19125             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
19126                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
19127                made both spots point to the same regexp body.) */
19128             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
19129             assert(!SvPVX(ret_x));
19130             ret_x->sv_u.svu_rx = temp->sv_any;
19131             temp->sv_any = NULL;
19132             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
19133             SvREFCNT_dec_NN(temp);
19134             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
19135                ing below will not set it. */
19136             SvCUR_set(ret_x, SvCUR(rx));
19137         }
19138     }
19139     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
19140        sv_force_normal(sv) is called.  */
19141     SvFAKE_on(ret_x);
19142     ret = ReANY(ret_x);
19143
19144     SvFLAGS(ret_x) |= SvUTF8(rx);
19145     /* We share the same string buffer as the original regexp, on which we
19146        hold a reference count, incremented when mother_re is set below.
19147        The string pointer is copied here, being part of the regexp struct.
19148      */
19149     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
19150            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
19151     if (r->offs) {
19152         const I32 npar = r->nparens+1;
19153         Newx(ret->offs, npar, regexp_paren_pair);
19154         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19155     }
19156     if (r->substrs) {
19157         Newx(ret->substrs, 1, struct reg_substr_data);
19158         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19159
19160         SvREFCNT_inc_void(ret->anchored_substr);
19161         SvREFCNT_inc_void(ret->anchored_utf8);
19162         SvREFCNT_inc_void(ret->float_substr);
19163         SvREFCNT_inc_void(ret->float_utf8);
19164
19165         /* check_substr and check_utf8, if non-NULL, point to either their
19166            anchored or float namesakes, and don't hold a second reference.  */
19167     }
19168     RX_MATCH_COPIED_off(ret_x);
19169 #ifdef PERL_ANY_COW
19170     ret->saved_copy = NULL;
19171 #endif
19172     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
19173     SvREFCNT_inc_void(ret->qr_anoncv);
19174     if (r->recurse_locinput)
19175         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19176
19177     return ret_x;
19178 }
19179 #endif
19180
19181 /* regfree_internal()
19182
19183    Free the private data in a regexp. This is overloadable by
19184    extensions. Perl takes care of the regexp structure in pregfree(),
19185    this covers the *pprivate pointer which technically perl doesn't
19186    know about, however of course we have to handle the
19187    regexp_internal structure when no extension is in use.
19188
19189    Note this is called before freeing anything in the regexp
19190    structure.
19191  */
19192
19193 void
19194 Perl_regfree_internal(pTHX_ REGEXP * const rx)
19195 {
19196     struct regexp *const r = ReANY(rx);
19197     RXi_GET_DECL(r,ri);
19198     GET_RE_DEBUG_FLAGS_DECL;
19199
19200     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
19201
19202     DEBUG_COMPILE_r({
19203         if (!PL_colorset)
19204             reginitcolors();
19205         {
19206             SV *dsv= sv_newmortal();
19207             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
19208                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
19209             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
19210                 PL_colors[4],PL_colors[5],s);
19211         }
19212     });
19213 #ifdef RE_TRACK_PATTERN_OFFSETS
19214     if (ri->u.offsets)
19215         Safefree(ri->u.offsets);             /* 20010421 MJD */
19216 #endif
19217     if (ri->code_blocks) {
19218         int n;
19219         for (n = 0; n < ri->num_code_blocks; n++)
19220             SvREFCNT_dec(ri->code_blocks[n].src_regex);
19221         Safefree(ri->code_blocks);
19222     }
19223
19224     if (ri->data) {
19225         int n = ri->data->count;
19226
19227         while (--n >= 0) {
19228           /* If you add a ->what type here, update the comment in regcomp.h */
19229             switch (ri->data->what[n]) {
19230             case 'a':
19231             case 'r':
19232             case 's':
19233             case 'S':
19234             case 'u':
19235                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
19236                 break;
19237             case 'f':
19238                 Safefree(ri->data->data[n]);
19239                 break;
19240             case 'l':
19241             case 'L':
19242                 break;
19243             case 'T':
19244                 { /* Aho Corasick add-on structure for a trie node.
19245                      Used in stclass optimization only */
19246                     U32 refcount;
19247                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
19248 #ifdef USE_ITHREADS
19249                     dVAR;
19250 #endif
19251                     OP_REFCNT_LOCK;
19252                     refcount = --aho->refcount;
19253                     OP_REFCNT_UNLOCK;
19254                     if ( !refcount ) {
19255                         PerlMemShared_free(aho->states);
19256                         PerlMemShared_free(aho->fail);
19257                          /* do this last!!!! */
19258                         PerlMemShared_free(ri->data->data[n]);
19259                         /* we should only ever get called once, so
19260                          * assert as much, and also guard the free
19261                          * which /might/ happen twice. At the least
19262                          * it will make code anlyzers happy and it
19263                          * doesn't cost much. - Yves */
19264                         assert(ri->regstclass);
19265                         if (ri->regstclass) {
19266                             PerlMemShared_free(ri->regstclass);
19267                             ri->regstclass = 0;
19268                         }
19269                     }
19270                 }
19271                 break;
19272             case 't':
19273                 {
19274                     /* trie structure. */
19275                     U32 refcount;
19276                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
19277 #ifdef USE_ITHREADS
19278                     dVAR;
19279 #endif
19280                     OP_REFCNT_LOCK;
19281                     refcount = --trie->refcount;
19282                     OP_REFCNT_UNLOCK;
19283                     if ( !refcount ) {
19284                         PerlMemShared_free(trie->charmap);
19285                         PerlMemShared_free(trie->states);
19286                         PerlMemShared_free(trie->trans);
19287                         if (trie->bitmap)
19288                             PerlMemShared_free(trie->bitmap);
19289                         if (trie->jump)
19290                             PerlMemShared_free(trie->jump);
19291                         PerlMemShared_free(trie->wordinfo);
19292                         /* do this last!!!! */
19293                         PerlMemShared_free(ri->data->data[n]);
19294                     }
19295                 }
19296                 break;
19297             default:
19298                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
19299                                                     ri->data->what[n]);
19300             }
19301         }
19302         Safefree(ri->data->what);
19303         Safefree(ri->data);
19304     }
19305
19306     Safefree(ri);
19307 }
19308
19309 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
19310 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
19311 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
19312
19313 /*
19314    re_dup_guts - duplicate a regexp.
19315
19316    This routine is expected to clone a given regexp structure. It is only
19317    compiled under USE_ITHREADS.
19318
19319    After all of the core data stored in struct regexp is duplicated
19320    the regexp_engine.dupe method is used to copy any private data
19321    stored in the *pprivate pointer. This allows extensions to handle
19322    any duplication it needs to do.
19323
19324    See pregfree() and regfree_internal() if you change anything here.
19325 */
19326 #if defined(USE_ITHREADS)
19327 #ifndef PERL_IN_XSUB_RE
19328 void
19329 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
19330 {
19331     dVAR;
19332     I32 npar;
19333     const struct regexp *r = ReANY(sstr);
19334     struct regexp *ret = ReANY(dstr);
19335
19336     PERL_ARGS_ASSERT_RE_DUP_GUTS;
19337
19338     npar = r->nparens+1;
19339     Newx(ret->offs, npar, regexp_paren_pair);
19340     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19341
19342     if (ret->substrs) {
19343         /* Do it this way to avoid reading from *r after the StructCopy().
19344            That way, if any of the sv_dup_inc()s dislodge *r from the L1
19345            cache, it doesn't matter.  */
19346         const bool anchored = r->check_substr
19347             ? r->check_substr == r->anchored_substr
19348             : r->check_utf8 == r->anchored_utf8;
19349         Newx(ret->substrs, 1, struct reg_substr_data);
19350         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19351
19352         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
19353         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
19354         ret->float_substr = sv_dup_inc(ret->float_substr, param);
19355         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
19356
19357         /* check_substr and check_utf8, if non-NULL, point to either their
19358            anchored or float namesakes, and don't hold a second reference.  */
19359
19360         if (ret->check_substr) {
19361             if (anchored) {
19362                 assert(r->check_utf8 == r->anchored_utf8);
19363                 ret->check_substr = ret->anchored_substr;
19364                 ret->check_utf8 = ret->anchored_utf8;
19365             } else {
19366                 assert(r->check_substr == r->float_substr);
19367                 assert(r->check_utf8 == r->float_utf8);
19368                 ret->check_substr = ret->float_substr;
19369                 ret->check_utf8 = ret->float_utf8;
19370             }
19371         } else if (ret->check_utf8) {
19372             if (anchored) {
19373                 ret->check_utf8 = ret->anchored_utf8;
19374             } else {
19375                 ret->check_utf8 = ret->float_utf8;
19376             }
19377         }
19378     }
19379
19380     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
19381     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
19382     if (r->recurse_locinput)
19383         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19384
19385     if (ret->pprivate)
19386         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
19387
19388     if (RX_MATCH_COPIED(dstr))
19389         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
19390     else
19391         ret->subbeg = NULL;
19392 #ifdef PERL_ANY_COW
19393     ret->saved_copy = NULL;
19394 #endif
19395
19396     /* Whether mother_re be set or no, we need to copy the string.  We
19397        cannot refrain from copying it when the storage points directly to
19398        our mother regexp, because that's
19399                1: a buffer in a different thread
19400                2: something we no longer hold a reference on
19401                so we need to copy it locally.  */
19402     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
19403     ret->mother_re   = NULL;
19404 }
19405 #endif /* PERL_IN_XSUB_RE */
19406
19407 /*
19408    regdupe_internal()
19409
19410    This is the internal complement to regdupe() which is used to copy
19411    the structure pointed to by the *pprivate pointer in the regexp.
19412    This is the core version of the extension overridable cloning hook.
19413    The regexp structure being duplicated will be copied by perl prior
19414    to this and will be provided as the regexp *r argument, however
19415    with the /old/ structures pprivate pointer value. Thus this routine
19416    may override any copying normally done by perl.
19417
19418    It returns a pointer to the new regexp_internal structure.
19419 */
19420
19421 void *
19422 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
19423 {
19424     dVAR;
19425     struct regexp *const r = ReANY(rx);
19426     regexp_internal *reti;
19427     int len;
19428     RXi_GET_DECL(r,ri);
19429
19430     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
19431
19432     len = ProgLen(ri);
19433
19434     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
19435           char, regexp_internal);
19436     Copy(ri->program, reti->program, len+1, regnode);
19437
19438
19439     reti->num_code_blocks = ri->num_code_blocks;
19440     if (ri->code_blocks) {
19441         int n;
19442         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
19443                 struct reg_code_block);
19444         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
19445                 struct reg_code_block);
19446         for (n = 0; n < ri->num_code_blocks; n++)
19447              reti->code_blocks[n].src_regex = (REGEXP*)
19448                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
19449     }
19450     else
19451         reti->code_blocks = NULL;
19452
19453     reti->regstclass = NULL;
19454
19455     if (ri->data) {
19456         struct reg_data *d;
19457         const int count = ri->data->count;
19458         int i;
19459
19460         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
19461                 char, struct reg_data);
19462         Newx(d->what, count, U8);
19463
19464         d->count = count;
19465         for (i = 0; i < count; i++) {
19466             d->what[i] = ri->data->what[i];
19467             switch (d->what[i]) {
19468                 /* see also regcomp.h and regfree_internal() */
19469             case 'a': /* actually an AV, but the dup function is identical.  */
19470             case 'r':
19471             case 's':
19472             case 'S':
19473             case 'u': /* actually an HV, but the dup function is identical.  */
19474                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
19475                 break;
19476             case 'f':
19477                 /* This is cheating. */
19478                 Newx(d->data[i], 1, regnode_ssc);
19479                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
19480                 reti->regstclass = (regnode*)d->data[i];
19481                 break;
19482             case 'T':
19483                 /* Trie stclasses are readonly and can thus be shared
19484                  * without duplication. We free the stclass in pregfree
19485                  * when the corresponding reg_ac_data struct is freed.
19486                  */
19487                 reti->regstclass= ri->regstclass;
19488                 /* FALLTHROUGH */
19489             case 't':
19490                 OP_REFCNT_LOCK;
19491                 ((reg_trie_data*)ri->data->data[i])->refcount++;
19492                 OP_REFCNT_UNLOCK;
19493                 /* FALLTHROUGH */
19494             case 'l':
19495             case 'L':
19496                 d->data[i] = ri->data->data[i];
19497                 break;
19498             default:
19499                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
19500                                                            ri->data->what[i]);
19501             }
19502         }
19503
19504         reti->data = d;
19505     }
19506     else
19507         reti->data = NULL;
19508
19509     reti->name_list_idx = ri->name_list_idx;
19510
19511 #ifdef RE_TRACK_PATTERN_OFFSETS
19512     if (ri->u.offsets) {
19513         Newx(reti->u.offsets, 2*len+1, U32);
19514         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
19515     }
19516 #else
19517     SetProgLen(reti,len);
19518 #endif
19519
19520     return (void*)reti;
19521 }
19522
19523 #endif    /* USE_ITHREADS */
19524
19525 #ifndef PERL_IN_XSUB_RE
19526
19527 /*
19528  - regnext - dig the "next" pointer out of a node
19529  */
19530 regnode *
19531 Perl_regnext(pTHX_ regnode *p)
19532 {
19533     I32 offset;
19534
19535     if (!p)
19536         return(NULL);
19537
19538     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
19539         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19540                                                 (int)OP(p), (int)REGNODE_MAX);
19541     }
19542
19543     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
19544     if (offset == 0)
19545         return(NULL);
19546
19547     return(p+offset);
19548 }
19549 #endif
19550
19551 STATIC void
19552 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
19553 {
19554     va_list args;
19555     STRLEN l1 = strlen(pat1);
19556     STRLEN l2 = strlen(pat2);
19557     char buf[512];
19558     SV *msv;
19559     const char *message;
19560
19561     PERL_ARGS_ASSERT_RE_CROAK2;
19562
19563     if (l1 > 510)
19564         l1 = 510;
19565     if (l1 + l2 > 510)
19566         l2 = 510 - l1;
19567     Copy(pat1, buf, l1 , char);
19568     Copy(pat2, buf + l1, l2 , char);
19569     buf[l1 + l2] = '\n';
19570     buf[l1 + l2 + 1] = '\0';
19571     va_start(args, pat2);
19572     msv = vmess(buf, &args);
19573     va_end(args);
19574     message = SvPV_const(msv,l1);
19575     if (l1 > 512)
19576         l1 = 512;
19577     Copy(message, buf, l1 , char);
19578     /* l1-1 to avoid \n */
19579     Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf));
19580 }
19581
19582 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
19583
19584 #ifndef PERL_IN_XSUB_RE
19585 void
19586 Perl_save_re_context(pTHX)
19587 {
19588     I32 nparens = -1;
19589     I32 i;
19590
19591     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
19592
19593     if (PL_curpm) {
19594         const REGEXP * const rx = PM_GETRE(PL_curpm);
19595         if (rx)
19596             nparens = RX_NPARENS(rx);
19597     }
19598
19599     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
19600      * that PL_curpm will be null, but that utf8.pm and the modules it
19601      * loads will only use $1..$3.
19602      * The t/porting/re_context.t test file checks this assumption.
19603      */
19604     if (nparens == -1)
19605         nparens = 3;
19606
19607     for (i = 1; i <= nparens; i++) {
19608         char digits[TYPE_CHARS(long)];
19609         const STRLEN len = my_snprintf(digits, sizeof(digits),
19610                                        "%lu", (long)i);
19611         GV *const *const gvp
19612             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
19613
19614         if (gvp) {
19615             GV * const gv = *gvp;
19616             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
19617                 save_scalar(gv);
19618         }
19619     }
19620 }
19621 #endif
19622
19623 #ifdef DEBUGGING
19624
19625 STATIC void
19626 S_put_code_point(pTHX_ SV *sv, UV c)
19627 {
19628     PERL_ARGS_ASSERT_PUT_CODE_POINT;
19629
19630     if (c > 255) {
19631         Perl_sv_catpvf(aTHX_ sv, "\\x{%04"UVXf"}", c);
19632     }
19633     else if (isPRINT(c)) {
19634         const char string = (char) c;
19635
19636         /* We use {phrase} as metanotation in the class, so also escape literal
19637          * braces */
19638         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
19639             sv_catpvs(sv, "\\");
19640         sv_catpvn(sv, &string, 1);
19641     }
19642     else if (isMNEMONIC_CNTRL(c)) {
19643         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
19644     }
19645     else {
19646         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
19647     }
19648 }
19649
19650 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
19651
19652 STATIC void
19653 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
19654 {
19655     /* Appends to 'sv' a displayable version of the range of code points from
19656      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
19657      * that have them, when they occur at the beginning or end of the range.
19658      * It uses hex to output the remaining code points, unless 'allow_literals'
19659      * is true, in which case the printable ASCII ones are output as-is (though
19660      * some of these will be escaped by put_code_point()).
19661      *
19662      * NOTE:  This is designed only for printing ranges of code points that fit
19663      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
19664      */
19665
19666     const unsigned int min_range_count = 3;
19667
19668     assert(start <= end);
19669
19670     PERL_ARGS_ASSERT_PUT_RANGE;
19671
19672     while (start <= end) {
19673         UV this_end;
19674         const char * format;
19675
19676         if (end - start < min_range_count) {
19677
19678             /* Output chars individually when they occur in short ranges */
19679             for (; start <= end; start++) {
19680                 put_code_point(sv, start);
19681             }
19682             break;
19683         }
19684
19685         /* If permitted by the input options, and there is a possibility that
19686          * this range contains a printable literal, look to see if there is
19687          * one. */
19688         if (allow_literals && start <= MAX_PRINT_A) {
19689
19690             /* If the character at the beginning of the range isn't an ASCII
19691              * printable, effectively split the range into two parts:
19692              *  1) the portion before the first such printable,
19693              *  2) the rest
19694              * and output them separately. */
19695             if (! isPRINT_A(start)) {
19696                 UV temp_end = start + 1;
19697
19698                 /* There is no point looking beyond the final possible
19699                  * printable, in MAX_PRINT_A */
19700                 UV max = MIN(end, MAX_PRINT_A);
19701
19702                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
19703                     temp_end++;
19704                 }
19705
19706                 /* Here, temp_end points to one beyond the first printable if
19707                  * found, or to one beyond 'max' if not.  If none found, make
19708                  * sure that we use the entire range */
19709                 if (temp_end > MAX_PRINT_A) {
19710                     temp_end = end + 1;
19711                 }
19712
19713                 /* Output the first part of the split range: the part that
19714                  * doesn't have printables, with the parameter set to not look
19715                  * for literals (otherwise we would infinitely recurse) */
19716                 put_range(sv, start, temp_end - 1, FALSE);
19717
19718                 /* The 2nd part of the range (if any) starts here. */
19719                 start = temp_end;
19720
19721                 /* We do a continue, instead of dropping down, because even if
19722                  * the 2nd part is non-empty, it could be so short that we want
19723                  * to output it as individual characters, as tested for at the
19724                  * top of this loop.  */
19725                 continue;
19726             }
19727
19728             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
19729              * output a sub-range of just the digits or letters, then process
19730              * the remaining portion as usual. */
19731             if (isALPHANUMERIC_A(start)) {
19732                 UV mask = (isDIGIT_A(start))
19733                            ? _CC_DIGIT
19734                              : isUPPER_A(start)
19735                                ? _CC_UPPER
19736                                : _CC_LOWER;
19737                 UV temp_end = start + 1;
19738
19739                 /* Find the end of the sub-range that includes just the
19740                  * characters in the same class as the first character in it */
19741                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
19742                     temp_end++;
19743                 }
19744                 temp_end--;
19745
19746                 /* For short ranges, don't duplicate the code above to output
19747                  * them; just call recursively */
19748                 if (temp_end - start < min_range_count) {
19749                     put_range(sv, start, temp_end, FALSE);
19750                 }
19751                 else {  /* Output as a range */
19752                     put_code_point(sv, start);
19753                     sv_catpvs(sv, "-");
19754                     put_code_point(sv, temp_end);
19755                 }
19756                 start = temp_end + 1;
19757                 continue;
19758             }
19759
19760             /* We output any other printables as individual characters */
19761             if (isPUNCT_A(start) || isSPACE_A(start)) {
19762                 while (start <= end && (isPUNCT_A(start)
19763                                         || isSPACE_A(start)))
19764                 {
19765                     put_code_point(sv, start);
19766                     start++;
19767                 }
19768                 continue;
19769             }
19770         } /* End of looking for literals */
19771
19772         /* Here is not to output as a literal.  Some control characters have
19773          * mnemonic names.  Split off any of those at the beginning and end of
19774          * the range to print mnemonically.  It isn't possible for many of
19775          * these to be in a row, so this won't overwhelm with output */
19776         while (isMNEMONIC_CNTRL(start) && start <= end) {
19777             put_code_point(sv, start);
19778             start++;
19779         }
19780         if (start < end && isMNEMONIC_CNTRL(end)) {
19781
19782             /* Here, the final character in the range has a mnemonic name.
19783              * Work backwards from the end to find the final non-mnemonic */
19784             UV temp_end = end - 1;
19785             while (isMNEMONIC_CNTRL(temp_end)) {
19786                 temp_end--;
19787             }
19788
19789             /* And separately output the interior range that doesn't start or
19790              * end with mnemonics */
19791             put_range(sv, start, temp_end, FALSE);
19792
19793             /* Then output the mnemonic trailing controls */
19794             start = temp_end + 1;
19795             while (start <= end) {
19796                 put_code_point(sv, start);
19797                 start++;
19798             }
19799             break;
19800         }
19801
19802         /* As a final resort, output the range or subrange as hex. */
19803
19804         this_end = (end < NUM_ANYOF_CODE_POINTS)
19805                     ? end
19806                     : NUM_ANYOF_CODE_POINTS - 1;
19807 #if NUM_ANYOF_CODE_POINTS > 256
19808         format = (this_end < 256)
19809                  ? "\\x%02"UVXf"-\\x%02"UVXf""
19810                  : "\\x{%04"UVXf"}-\\x{%04"UVXf"}";
19811 #else
19812         format = "\\x%02"UVXf"-\\x%02"UVXf"";
19813 #endif
19814         GCC_DIAG_IGNORE(-Wformat-nonliteral);
19815         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
19816         GCC_DIAG_RESTORE;
19817         break;
19818     }
19819 }
19820
19821 STATIC void
19822 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
19823 {
19824     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
19825      * 'invlist' */
19826
19827     UV start, end;
19828     bool allow_literals = TRUE;
19829
19830     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
19831
19832     /* Generally, it is more readable if printable characters are output as
19833      * literals, but if a range (nearly) spans all of them, it's best to output
19834      * it as a single range.  This code will use a single range if all but 2
19835      * ASCII printables are in it */
19836     invlist_iterinit(invlist);
19837     while (invlist_iternext(invlist, &start, &end)) {
19838
19839         /* If the range starts beyond the final printable, it doesn't have any
19840          * in it */
19841         if (start > MAX_PRINT_A) {
19842             break;
19843         }
19844
19845         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
19846          * all but two, the range must start and end no later than 2 from
19847          * either end */
19848         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
19849             if (end > MAX_PRINT_A) {
19850                 end = MAX_PRINT_A;
19851             }
19852             if (start < ' ') {
19853                 start = ' ';
19854             }
19855             if (end - start >= MAX_PRINT_A - ' ' - 2) {
19856                 allow_literals = FALSE;
19857             }
19858             break;
19859         }
19860     }
19861     invlist_iterfinish(invlist);
19862
19863     /* Here we have figured things out.  Output each range */
19864     invlist_iterinit(invlist);
19865     while (invlist_iternext(invlist, &start, &end)) {
19866         if (start >= NUM_ANYOF_CODE_POINTS) {
19867             break;
19868         }
19869         put_range(sv, start, end, allow_literals);
19870     }
19871     invlist_iterfinish(invlist);
19872
19873     return;
19874 }
19875
19876 STATIC SV*
19877 S_put_charclass_bitmap_innards_common(pTHX_
19878         SV* invlist,            /* The bitmap */
19879         SV* posixes,            /* Under /l, things like [:word:], \S */
19880         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
19881         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
19882         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
19883         const bool invert       /* Is the result to be inverted? */
19884 )
19885 {
19886     /* Create and return an SV containing a displayable version of the bitmap
19887      * and associated information determined by the input parameters. */
19888
19889     SV * output;
19890
19891     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
19892
19893     if (invert) {
19894         output = newSVpvs("^");
19895     }
19896     else {
19897         output = newSVpvs("");
19898     }
19899
19900     /* First, the code points in the bitmap that are unconditionally there */
19901     put_charclass_bitmap_innards_invlist(output, invlist);
19902
19903     /* Traditionally, these have been placed after the main code points */
19904     if (posixes) {
19905         sv_catsv(output, posixes);
19906     }
19907
19908     if (only_utf8 && _invlist_len(only_utf8)) {
19909         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
19910         put_charclass_bitmap_innards_invlist(output, only_utf8);
19911     }
19912
19913     if (not_utf8 && _invlist_len(not_utf8)) {
19914         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
19915         put_charclass_bitmap_innards_invlist(output, not_utf8);
19916     }
19917
19918     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
19919         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
19920         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
19921
19922         /* This is the only list in this routine that can legally contain code
19923          * points outside the bitmap range.  The call just above to
19924          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
19925          * output them here.  There's about a half-dozen possible, and none in
19926          * contiguous ranges longer than 2 */
19927         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
19928             UV start, end;
19929             SV* above_bitmap = NULL;
19930
19931             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
19932
19933             invlist_iterinit(above_bitmap);
19934             while (invlist_iternext(above_bitmap, &start, &end)) {
19935                 UV i;
19936
19937                 for (i = start; i <= end; i++) {
19938                     put_code_point(output, i);
19939                 }
19940             }
19941             invlist_iterfinish(above_bitmap);
19942             SvREFCNT_dec_NN(above_bitmap);
19943         }
19944     }
19945
19946     /* If the only thing we output is the '^', clear it */
19947     if (invert && SvCUR(output) == 1) {
19948         SvCUR_set(output, 0);
19949     }
19950
19951     return output;
19952 }
19953
19954 STATIC bool
19955 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
19956                                      char *bitmap,
19957                                      SV *nonbitmap_invlist,
19958                                      SV *only_utf8_locale_invlist,
19959                                      const regnode * const node)
19960 {
19961     /* Appends to 'sv' a displayable version of the innards of the bracketed
19962      * character class defined by the other arguments:
19963      *  'bitmap' points to the bitmap.
19964      *  'nonbitmap_invlist' is an inversion list of the code points that are in
19965      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
19966      *      none.  The reasons for this could be that they require some
19967      *      condition such as the target string being or not being in UTF-8
19968      *      (under /d), or because they came from a user-defined property that
19969      *      was not resolved at the time of the regex compilation (under /u)
19970      *  'only_utf8_locale_invlist' is an inversion list of the code points that
19971      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
19972      *  'node' is the regex pattern node.  It is needed only when the above two
19973      *      parameters are not null, and is passed so that this routine can
19974      *      tease apart the various reasons for them.
19975      *
19976      * It returns TRUE if there was actually something output.  (It may be that
19977      * the bitmap, etc is empty.)
19978      *
19979      * When called for outputting the bitmap of a non-ANYOF node, just pass the
19980      * bitmap, with the succeeding parameters set to NULL.
19981      *
19982      */
19983
19984     /* In general, it tries to display the 'cleanest' representation of the
19985      * innards, choosing whether to display them inverted or not, regardless of
19986      * whether the class itself is to be inverted.  However,  there are some
19987      * cases where it can't try inverting, as what actually matches isn't known
19988      * until runtime, and hence the inversion isn't either. */
19989     bool inverting_allowed = TRUE;
19990
19991     int i;
19992     STRLEN orig_sv_cur = SvCUR(sv);
19993
19994     SV* invlist;            /* Inversion list we accumulate of code points that
19995                                are unconditionally matched */
19996     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
19997                                UTF-8 */
19998     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
19999                              */
20000     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
20001     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
20002                                        is UTF-8 */
20003
20004     SV* as_is_display;      /* The output string when we take the inputs
20005                               literally */
20006     SV* inverted_display;   /* The output string when we invert the inputs */
20007
20008     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
20009
20010     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
20011                                                    to match? */
20012     /* We are biased in favor of displaying things without them being inverted,
20013      * as that is generally easier to understand */
20014     const int bias = 5;
20015
20016     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
20017
20018     /* Start off with whatever code points are passed in.  (We clone, so we
20019      * don't change the caller's list) */
20020     if (nonbitmap_invlist) {
20021         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
20022         invlist = invlist_clone(nonbitmap_invlist);
20023     }
20024     else {  /* Worst case size is every other code point is matched */
20025         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
20026     }
20027
20028     if (flags) {
20029         if (OP(node) == ANYOFD) {
20030
20031             /* This flag indicates that the code points below 0x100 in the
20032              * nonbitmap list are precisely the ones that match only when the
20033              * target is UTF-8 (they should all be non-ASCII). */
20034             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
20035             {
20036                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
20037                 _invlist_subtract(invlist, only_utf8, &invlist);
20038             }
20039
20040             /* And this flag for matching all non-ASCII 0xFF and below */
20041             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
20042             {
20043                 not_utf8 = invlist_clone(PL_UpperLatin1);
20044             }
20045         }
20046         else if (OP(node) == ANYOFL) {
20047
20048             /* If either of these flags are set, what matches isn't
20049              * determinable except during execution, so don't know enough here
20050              * to invert */
20051             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
20052                 inverting_allowed = FALSE;
20053             }
20054
20055             /* What the posix classes match also varies at runtime, so these
20056              * will be output symbolically. */
20057             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
20058                 int i;
20059
20060                 posixes = newSVpvs("");
20061                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
20062                     if (ANYOF_POSIXL_TEST(node,i)) {
20063                         sv_catpv(posixes, anyofs[i]);
20064                     }
20065                 }
20066             }
20067         }
20068     }
20069
20070     /* Accumulate the bit map into the unconditional match list */
20071     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
20072         if (BITMAP_TEST(bitmap, i)) {
20073             int start = i++;
20074             for (; i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i); i++) {
20075                 /* empty */
20076             }
20077             invlist = _add_range_to_invlist(invlist, start, i-1);
20078         }
20079     }
20080
20081     /* Make sure that the conditional match lists don't have anything in them
20082      * that match unconditionally; otherwise the output is quite confusing.
20083      * This could happen if the code that populates these misses some
20084      * duplication. */
20085     if (only_utf8) {
20086         _invlist_subtract(only_utf8, invlist, &only_utf8);
20087     }
20088     if (not_utf8) {
20089         _invlist_subtract(not_utf8, invlist, &not_utf8);
20090     }
20091
20092     if (only_utf8_locale_invlist) {
20093
20094         /* Since this list is passed in, we have to make a copy before
20095          * modifying it */
20096         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
20097
20098         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
20099
20100         /* And, it can get really weird for us to try outputting an inverted
20101          * form of this list when it has things above the bitmap, so don't even
20102          * try */
20103         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20104             inverting_allowed = FALSE;
20105         }
20106     }
20107
20108     /* Calculate what the output would be if we take the input as-is */
20109     as_is_display = put_charclass_bitmap_innards_common(invlist,
20110                                                     posixes,
20111                                                     only_utf8,
20112                                                     not_utf8,
20113                                                     only_utf8_locale,
20114                                                     invert);
20115
20116     /* If have to take the output as-is, just do that */
20117     if (! inverting_allowed) {
20118         sv_catsv(sv, as_is_display);
20119     }
20120     else { /* But otherwise, create the output again on the inverted input, and
20121               use whichever version is shorter */
20122
20123         int inverted_bias, as_is_bias;
20124
20125         /* We will apply our bias to whichever of the the results doesn't have
20126          * the '^' */
20127         if (invert) {
20128             invert = FALSE;
20129             as_is_bias = bias;
20130             inverted_bias = 0;
20131         }
20132         else {
20133             invert = TRUE;
20134             as_is_bias = 0;
20135             inverted_bias = bias;
20136         }
20137
20138         /* Now invert each of the lists that contribute to the output,
20139          * excluding from the result things outside the possible range */
20140
20141         /* For the unconditional inversion list, we have to add in all the
20142          * conditional code points, so that when inverted, they will be gone
20143          * from it */
20144         _invlist_union(only_utf8, invlist, &invlist);
20145         _invlist_union(not_utf8, invlist, &invlist);
20146         _invlist_union(only_utf8_locale, invlist, &invlist);
20147         _invlist_invert(invlist);
20148         _invlist_intersection(invlist, PL_InBitmap, &invlist);
20149
20150         if (only_utf8) {
20151             _invlist_invert(only_utf8);
20152             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
20153         }
20154
20155         if (not_utf8) {
20156             _invlist_invert(not_utf8);
20157             _invlist_intersection(not_utf8, PL_UpperLatin1, &not_utf8);
20158         }
20159
20160         if (only_utf8_locale) {
20161             _invlist_invert(only_utf8_locale);
20162             _invlist_intersection(only_utf8_locale,
20163                                   PL_InBitmap,
20164                                   &only_utf8_locale);
20165         }
20166
20167         inverted_display = put_charclass_bitmap_innards_common(
20168                                             invlist,
20169                                             posixes,
20170                                             only_utf8,
20171                                             not_utf8,
20172                                             only_utf8_locale, invert);
20173
20174         /* Use the shortest representation, taking into account our bias
20175          * against showing it inverted */
20176         if (SvCUR(inverted_display) + inverted_bias
20177             < SvCUR(as_is_display) + as_is_bias)
20178         {
20179             sv_catsv(sv, inverted_display);
20180         }
20181         else {
20182             sv_catsv(sv, as_is_display);
20183         }
20184
20185         SvREFCNT_dec_NN(as_is_display);
20186         SvREFCNT_dec_NN(inverted_display);
20187     }
20188
20189     SvREFCNT_dec_NN(invlist);
20190     SvREFCNT_dec(only_utf8);
20191     SvREFCNT_dec(not_utf8);
20192     SvREFCNT_dec(posixes);
20193     SvREFCNT_dec(only_utf8_locale);
20194
20195     return SvCUR(sv) > orig_sv_cur;
20196 }
20197
20198 #define CLEAR_OPTSTART                                                       \
20199     if (optstart) STMT_START {                                               \
20200         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
20201                               " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
20202         optstart=NULL;                                                       \
20203     } STMT_END
20204
20205 #define DUMPUNTIL(b,e)                                                       \
20206                     CLEAR_OPTSTART;                                          \
20207                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
20208
20209 STATIC const regnode *
20210 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
20211             const regnode *last, const regnode *plast,
20212             SV* sv, I32 indent, U32 depth)
20213 {
20214     U8 op = PSEUDO;     /* Arbitrary non-END op. */
20215     const regnode *next;
20216     const regnode *optstart= NULL;
20217
20218     RXi_GET_DECL(r,ri);
20219     GET_RE_DEBUG_FLAGS_DECL;
20220
20221     PERL_ARGS_ASSERT_DUMPUNTIL;
20222
20223 #ifdef DEBUG_DUMPUNTIL
20224     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
20225         last ? last-start : 0,plast ? plast-start : 0);
20226 #endif
20227
20228     if (plast && plast < last)
20229         last= plast;
20230
20231     while (PL_regkind[op] != END && (!last || node < last)) {
20232         assert(node);
20233         /* While that wasn't END last time... */
20234         NODE_ALIGN(node);
20235         op = OP(node);
20236         if (op == CLOSE || op == WHILEM)
20237             indent--;
20238         next = regnext((regnode *)node);
20239
20240         /* Where, what. */
20241         if (OP(node) == OPTIMIZED) {
20242             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
20243                 optstart = node;
20244             else
20245                 goto after_print;
20246         } else
20247             CLEAR_OPTSTART;
20248
20249         regprop(r, sv, node, NULL, NULL);
20250         Perl_re_printf( aTHX_  "%4"IVdf":%*s%s", (IV)(node - start),
20251                       (int)(2*indent + 1), "", SvPVX_const(sv));
20252
20253         if (OP(node) != OPTIMIZED) {
20254             if (next == NULL)           /* Next ptr. */
20255                 Perl_re_printf( aTHX_  " (0)");
20256             else if (PL_regkind[(U8)op] == BRANCH
20257                      && PL_regkind[OP(next)] != BRANCH )
20258                 Perl_re_printf( aTHX_  " (FAIL)");
20259             else
20260                 Perl_re_printf( aTHX_  " (%"IVdf")", (IV)(next - start));
20261             Perl_re_printf( aTHX_ "\n");
20262         }
20263
20264       after_print:
20265         if (PL_regkind[(U8)op] == BRANCHJ) {
20266             assert(next);
20267             {
20268                 const regnode *nnode = (OP(next) == LONGJMP
20269                                        ? regnext((regnode *)next)
20270                                        : next);
20271                 if (last && nnode > last)
20272                     nnode = last;
20273                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
20274             }
20275         }
20276         else if (PL_regkind[(U8)op] == BRANCH) {
20277             assert(next);
20278             DUMPUNTIL(NEXTOPER(node), next);
20279         }
20280         else if ( PL_regkind[(U8)op]  == TRIE ) {
20281             const regnode *this_trie = node;
20282             const char op = OP(node);
20283             const U32 n = ARG(node);
20284             const reg_ac_data * const ac = op>=AHOCORASICK ?
20285                (reg_ac_data *)ri->data->data[n] :
20286                NULL;
20287             const reg_trie_data * const trie =
20288                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
20289 #ifdef DEBUGGING
20290             AV *const trie_words
20291                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
20292 #endif
20293             const regnode *nextbranch= NULL;
20294             I32 word_idx;
20295             sv_setpvs(sv, "");
20296             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
20297                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
20298
20299                 Perl_re_indentf( aTHX_  "%s ",
20300                     indent+3,
20301                     elem_ptr
20302                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
20303                                 SvCUR(*elem_ptr), 60,
20304                                 PL_colors[0], PL_colors[1],
20305                                 (SvUTF8(*elem_ptr)
20306                                  ? PERL_PV_ESCAPE_UNI
20307                                  : 0)
20308                                 | PERL_PV_PRETTY_ELLIPSES
20309                                 | PERL_PV_PRETTY_LTGT
20310                             )
20311                     : "???"
20312                 );
20313                 if (trie->jump) {
20314                     U16 dist= trie->jump[word_idx+1];
20315                     Perl_re_printf( aTHX_  "(%"UVuf")\n",
20316                                (UV)((dist ? this_trie + dist : next) - start));
20317                     if (dist) {
20318                         if (!nextbranch)
20319                             nextbranch= this_trie + trie->jump[0];
20320                         DUMPUNTIL(this_trie + dist, nextbranch);
20321                     }
20322                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
20323                         nextbranch= regnext((regnode *)nextbranch);
20324                 } else {
20325                     Perl_re_printf( aTHX_  "\n");
20326                 }
20327             }
20328             if (last && next > last)
20329                 node= last;
20330             else
20331                 node= next;
20332         }
20333         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
20334             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
20335                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
20336         }
20337         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
20338             assert(next);
20339             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
20340         }
20341         else if ( op == PLUS || op == STAR) {
20342             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
20343         }
20344         else if (PL_regkind[(U8)op] == ANYOF) {
20345             /* arglen 1 + class block */
20346             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
20347                           ? ANYOF_POSIXL_SKIP
20348                           : ANYOF_SKIP);
20349             node = NEXTOPER(node);
20350         }
20351         else if (PL_regkind[(U8)op] == EXACT) {
20352             /* Literal string, where present. */
20353             node += NODE_SZ_STR(node) - 1;
20354             node = NEXTOPER(node);
20355         }
20356         else {
20357             node = NEXTOPER(node);
20358             node += regarglen[(U8)op];
20359         }
20360         if (op == CURLYX || op == OPEN)
20361             indent++;
20362     }
20363     CLEAR_OPTSTART;
20364 #ifdef DEBUG_DUMPUNTIL
20365     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
20366 #endif
20367     return node;
20368 }
20369
20370 #endif  /* DEBUGGING */
20371
20372 /*
20373  * ex: set ts=8 sts=4 sw=4 et:
20374  */